home *** CD-ROM | disk | FTP | other *** search
/ BBS Toolkit / BBS Toolkit.iso / rbbs_pc / 172bbas.zip / RBBSSUB4.BAS < prev    next >
BASIC Source File  |  1989-07-27  |  121KB  |  3,311 lines
  1. ' $linesize:132
  2. ' $title: 'RBBSSUB4.BAS CPC17.2B, Copyright 1986 - 89 by D. Thomas Mack'
  3. '  Copyright 1989 by D. Thomas Mack, all rights reserved.
  4. '  Name ...............: RBBSSUB4.BAS
  5. '  Written by .........: D. Thomas Mack
  6. '  First Released .....: May 28, 1989
  7. '  Subsequent Releases.: 07-30-89
  8. '  Copyright ..........: 1986 - 1989
  9. '  Purpose.............: The Remote Bulletin Board System for the IBM PC,
  10. '     RBBS-PC.BAS utilizes a lot of common subroutines.  Those that do not
  11. '     require error trapping are incorporated within RBBSSUB 2-5 as
  12. '     separately callable subroutines in order to free up as much
  13. '     code as possible within the 64K code segment used by RBBS-PC.BAS.
  14. '  Parameters..........: Most parameters are passed via a COMMON statement.
  15. '
  16. ' Subroutine  Line               Function of Subroutine
  17. '   Name     Number
  18. '  ANYBUT     59760   Determine where a "word" begins
  19. '  ASKUSERS   64003   Ask users questions based on a script and save answers
  20. '  ASKMORE    59858   Check whether screen full
  21. '  AUTOPAGE   60300   Check whether to notify sysop caller is on
  22. ' BADFILECHAR 59800   Check file name for bad character
  23. '  BRACKET    59960   Puts strings around a substring
  24. '  BUFFILE    58400   Write a file to the user quickly
  25. '  BUFSTRNG   58300   Write a string with imbedded CR/LF to the user quickly
  26. '  CHKCOLOR   59930   Highlighting based on search string
  27. '  CHKNARY    58190   Check for the occurance of a string in an array
  28. '  COLORDIR   59920   Adds colorization to FMS directory entry
  29. '  COLORPMT   59940  Colorizes prompts
  30. '  COMPDATE   59880+  Produces a computational data from YY, MM, DD
  31. '  CONFMAIL   59854   Check conference mail waiting
  32. '  CONVDIRS   58950   Checks for U & A (shorthand) and converts appropriately
  33. '  CSTRDATE   59201   Compress date in string format to 2 characters
  34. '  EOFCOMM    60000   Determine whether any chars in comm port buffer
  35. '  EXPDATE    59890  Calculate registration expiration date
  36. '  FAKEXRPT   62650   Write out file transfer report for protocols that don't
  37. '  FINDEND    58770   Find where a "word" ends
  38. '  FINDFILE   58790   Determine whether a file exists without opening it
  39. '  FINDLAST   58600   Find last occurence of a string
  40. '  FMS        58200   Search the upload management system for entries
  41. '  GETALL     59780   Get list of all directories to display
  42. '  GETDIRS    58895   Prompts for directories for file list/new/search cmds
  43. '  GETMATTR   62530   Restore attributes of original message
  44. '  GETYMD     59204   Pulls YY, MM, or DD from a 2 byte stored date
  45. '  GSANDR     60100   Global search and replace
  46. '  LOGDOWN    59400   Records download in private directory
  47. '  MARKTIME   60200   Give visual feedback during lengthy process
  48. '  METAGSR    60130   Meta statement global search and replace
  49. '  MIMPORT    59698   Allow local user to import a text file to a message
  50. '  MUZAK      59100   Play musical themes for different RBBS functions
  51. '  NEWPASWRD  60668   Get a new password
  52. '  PERSFILE   59300   View and select personal files for downloading
  53. '  PROTOCOL   62600   Determine if external protocols are available
  54. '  PUTMATTR   62520   Save attributes of original message
  55. '  REMOVE     58210   Remove characters from within strings
  56. '  ROTORSDIR  58700   Searches for a file using list of subdirs
  57. '  RPTTIME    62540  Report date/time and time on
  58. '  SETABORT   58750   Set time for a process to abort
  59. '  SETECHO    59600   Set RBBS properly for who is to echo
  60. '  SETHILITE  59934   Set user preference on highlighting
  61. '  SETUGD     59980   Sets graphic preference for text file display
  62. '  SMARTTXT   58250   Process SMART TEXT control strings
  63. '  SUBMENU    59500   Processes options that have sub-menus
  64. '  TIMEDOUT   63000   Write timed exit semaphore file
  65. '  TIMELOCK   60150   Check for TIME LOCK on certain features
  66. '  TRANSFER   62624   RBBS-PC support for external protocols for file transfer
  67. '  TOGGLE     57000   Toggles or views user options
  68. ' TWOBYTEDATE 59200   Reduces a data to 2 byte string for space compression
  69. '  UNCDATE    59902   Uncompresses a 2 byte date
  70. '  USERCOLOR  59965   Lets user set color for text and whether bold
  71. '  USERFACE   59450   Processes programmable user interface
  72. '  VIEWARC    64600   Display .ARC file contents to user
  73. '  XFRETURN   62629   Private door exit routine
  74. '  WIPELINE   58800   Wipes away a line so next prints in its place
  75. '  WORDWRAP   59710  Adjust a message --wrap linesand perserve paragraphs
  76. '
  77. '  $INCLUDE: 'RBBS-VAR.BAS'
  78. '
  79. 57000 ' $SUBTITLE: 'TOGGLE - Toggle User Preferences'
  80. ' $PAGE
  81. '
  82. '  NAME    -- TOGGLE
  83. '
  84. '  INPUTS  -- TOGGLE.OPTION      Option to toggle or view
  85. '                                           according to the following:
  86. '    TOGGLE.OPTION         PREFERENCE
  87. '   TOGGLE   VIEW
  88. '     1       -1           Autodownload
  89. '     2       -2           Bulletin review on logon
  90. '     3       -3           Case change
  91. '     4       -4           File review on logon
  92. '     5       -5           Highlight
  93. '     6       -6           Line feeds
  94. '     7       -7           Nulls
  95. '     8       -8           TurboKey
  96. '     9       -9           Expert
  97. '    10      -10           Bell
  98. '
  99. '  OUTPUTS -- SUBROUTINE.PARAMETER   passed from TPUT
  100. '
  101. '  PURPOSE -- Sets or views any single user preference value
  102. '
  103.       SUB TOGGLE (TOGGLE.OPTION) STATIC
  104.       SUBROUTINE.PARAMETER = 0
  105.       IF TOGGLE.OPTION < 0 THEN _
  106.          GOTO 57005
  107.       ON TOGGLE.OPTION GOSUB _
  108.          57010, _         'Autodownload
  109.          57120, _         'Bulletin review on logon
  110.          57260, _         'Case change
  111.          57150, _         'File review on logon
  112.          57040, _         'Highlight
  113.          57100, _         'Line feeds
  114.          57210, _         'Nulls
  115.          57230, _         'TurboKey
  116.          57190, _         'Expert
  117.          57170            'Bell
  118.       EXIT SUB
  119. 57005 CALL ASKMORE ("",TRUE,TRUE,X,TRUE)
  120.       ON -TOGGLE.OPTION GOSUB _
  121.          57030, _         'Autodownload
  122.          57130, _         'Bulletin review on logon
  123.          57270, _         'Case change
  124.          57160, _         'File review on logon
  125.          57050, _         'Highlight
  126.          57110, _         'Line feeds
  127.          57220, _         'Nulls
  128.          57240, _         'TurboKey
  129.          57200, _         'Expert
  130.          57180            'Bell
  131.       EXIT SUB
  132. 57010 IF AUTODOWNLOAD.DESIRED THEN _
  133.          GOTO 57020
  134.       IF NOT AUTODOWNLOAD.VERIFIED THEN _
  135.          CALL TESTUSER
  136.       IF NOT AUTODOWNLOAD.AVAILABLE THEN _
  137.          CALL QTPUT1 ("Your comm pgm does not support AUTODOWNLOAD") : _
  138.          AUTODOWNLOAD.DESIRED = TRUE
  139. 57020 AUTODOWNLOAD.DESIRED = NOT AUTODOWNLOAD.DESIRED
  140. 57030 A$ = "Autodownload " + FNOFFON$(AUTODOWNLOAD.DESIRED)
  141.      CALL QTPUT1 (A$)
  142.      RETURN
  143. 57040 IF EMPHASIZE.ON.DEF$ = "" THEN _
  144.         CALL QTPUT1 ("Highlighting unavailable") : _
  145.         RETURN
  146.      CALL SETHILITE (NOT HIGHLIGHT.OFF)
  147.      IF HIGHLIGHT.OFF THEN _
  148.         CALL QTPUT (COLOR.RESET$,0)
  149.      GOSUB 57050
  150.      CALL USERCOLOR
  151.      RETURN
  152. 57050 IF EMPHASIZE.ON$ <> "" THEN _
  153.         EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _
  154.         ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m"
  155.      CALL QTPUT1 (EMPHASIZE.ON$ + "Highlighting" + EMPHASIZE.OFF$ + _
  156.                  " " + FNOFFON$(NOT HIGHLIGHT.OFF))
  157.      RETURN
  158. 57100 LINE.FEEDS = NOT LINE.FEEDS
  159.       IF LOCAL.USER THEN _
  160.          LINE.FEEDS = TRUE
  161. 57110 CALL QTPUT1 ("Line Feeds " + FNOFFON$(LINE.FEEDS))
  162.       CALL SETCRLF
  163.       RETURN
  164. 57120 CHECK.BULLETIN.LOGON = NOT CHECK.BULLETIN.LOGON
  165. 57130 A$ = MID$("SKIP CHECK",1 -5 * CHECK.BULLETIN.LOGON,5) + _
  166.            " old BULLETINS in logon"
  167.       CALL QTPUT1 (A$)
  168.       RETURN
  169. 57150 SKIP.FILES.LOGON = NOT SKIP.FILES.LOGON
  170. 57160 A$ = MID$("CHECKSKIP",1 -5 * SKIP.FILES.LOGON,5) + _
  171.            " new files in logon"
  172.       CALL QTPUT1 (A$)
  173.       RETURN
  174. 57170 PROMPT.BELL = NOT PROMPT.BELL
  175. 57180 A$ = "Prompt Bell " + FNOFFON$(PROMPT.BELL)
  176.       CALL QTPUT1 (A$)
  177.       RETURN
  178. 57190 EXPERT.USER = NOT EXPERT.USER
  179.       CALL SETEXPERT
  180. 57200 A$ = MID$("NoviceExpert",1 -6 * EXPERT.USER,6)
  181.       CALL QTPUT1 (A$)
  182.       RETURN
  183. 57210 NULLS = NOT NULLS
  184.       NUL$ = MID$(STRING$(5,0),1, - 5 * NULLS)
  185.       CALL SETCRLF
  186. 57220 A$ = "Nulls " + FNOFFON$(NULLS)
  187.       CALL QTPUT1 (A$)
  188.       RETURN
  189. 57230 TURBO.KEY.USER = NOT TURBO.KEY.USER
  190. 57240 CALL QTPUT1 ("TurboKey " + FNOFFON$(TURBO.KEY.USER))
  191.       RETURN
  192. 57260 UPPER.CASE = NOT UPPER.CASE
  193. 57270 A$ = "UPPER CASE " + _
  194.             MID$("and lowerONLY",1 - 9 * UPPER.CASE,9)
  195.       CALL QTPUT1 (A$)
  196. 57280 USE.TPUT = (UPPER.CASE OR XON.XOFF)
  197.       RETURN
  198.       END SUB
  199. '
  200. 58190 ' $SUBTITLE: 'CHKNARY - subroutine to check for a string in an array'
  201. ' $PAGE
  202. '
  203. '  NAME    -- CHKNARY
  204. '
  205. '  INPUTS  -- PARAMETER                      MEANING
  206. '             ELEMENT$                THE STRING TO CHECK FOR
  207. '             ARRAY$()                THE ARRAY TO BE SEARCHED
  208. '             NUM.ENTRIES.TO.SEARCH   NUMBER OF ENTRIES WITHIN IN
  209. '                                                THE ARRAY TO BE SEARCHED
  210. '
  211. '  OUTPUTS -- IS.IN.ARA               0 = STRING NOT FOUND IN THE
  212. '                                         ARRAY SPECIFIED
  213. '                                     OTHERWISE IT IS THE NUMBER OF
  214. '                                     ELEMENT WITHIN THE ARRAY THAT
  215. '                                     WAS FOUND TO MATCH
  216. '
  217. '  PURPOSE -- Search an array for a specified string and, if found,
  218. '             return the number of the element that matched.
  219. '
  220.       SUB CHKNARY (ELEMENT$,ARRAY$(1),NUM.ENTRIES.TO.SEARCH,IS.IN.ARA) STATIC
  221.       IS.IN.ARA = 1
  222.       CALL ALLCAPS (ELEMENT$)
  223.       MAX.TRIES = NUM.ENTRIES.TO.SEARCH + 1
  224.       ARRAY$(MAX.TRIES) = ELEMENT$
  225.       WHILE ARRAY$(IS.IN.ARA) <> ELEMENT$
  226.          IS.IN.ARA = IS.IN.ARA + 1
  227.       WEND
  228.       IF IS.IN.ARA = MAX.TRIES THEN _
  229.          IS.IN.ARA = 0
  230.       END SUB
  231. 58200 ' $SUBTITLE: 'FMS - subroutine to search the upload management system'
  232. ' $PAGE
  233. '
  234. '  NAME    -- FMS
  235. '
  236. '  INPUTS  -- PARAMETER                      MEANING
  237. '             DIR.TO.SEARCH$          RBBS-PC "DIR" CATEGORY TO LOOK
  238. '                                     FOR
  239. '             SEARCH.STRING$          STRING TO SEARCH FOR
  240. '             SEARCH.DATE$            DATE TO SEARCH FOR
  241. '             CATEGORY.NAME$()
  242. '             CATEGORY.CODE$()
  243. '             CATEGORY.DESC$()
  244. '             CAT.FOUND
  245. '             NUM.CATEGORIES
  246. '
  247. '  OUTPUTS -- PROCESSED.IN.FMS
  248. '             DOWNLOAD.FLAG
  249. '
  250. '  PURPOSE -- To search the file management system and display the
  251. '             files being searched for as well as the catetory descriptions
  252. '
  253.       SUB FMS (DIR.TO.SEARCH$,SEARCH.STRING$,SEARCH.DATE$, _
  254.                PROCESSED.IN.FMS,CATEGORY.NAME$(1),CATEGORY.CODE$(1), _
  255.                CATEGORY.DESC$(1),DOWNLOAD.FLAG,CAT.FOUND,ABORT.INDEX) STATIC
  256.       DOWNLOAD.FLAG = 0
  257.       CALL CHKNARY (DIR.TO.SEARCH$,CATEGORY.NAME$(),NUM.CATEGORIES,CAT.FOUND)
  258.       PROCESSED.IN.FMS = PROCESSED.IN.FMS OR (CAT.FOUND > 0)
  259.       IF PROCESSED.IN.FMS THEN _
  260.          SUBROUTINE.PARAMETER = 5 : _
  261.          GOSUB 58202 : _
  262.          A$ = "Scanning directory " + _
  263.               DIR.TO.SEARCH$ + _
  264.               HDR$ + _
  265.               " - " + _
  266.               CATEGORY.DESC$(CAT.FOUND) : _
  267.          CALL TPUT : _
  268.          CAT$ = CATEGORY.CODE$(CAT.FOUND) : _
  269.          CALL DISUPDIR (CAT$,SEARCH.STRING$,SEARCH.DATE$,DOWNLOAD.FLAG,ABORT.INDEX)
  270.       EXIT SUB
  271. 58202 A$ = SEARCH.DATE$
  272.       IF LEN(A$) > 0 THEN _
  273.          A$ = MID$(A$,3) + LEFT$(A$,2)
  274.       HDR$ = " for " + _
  275.              SEARCH.STRING$ + _
  276.              A$
  277.       IF LEN(HDR$) < 6 THEN _
  278.          HDR$ = ""
  279.       RETURN
  280.       END SUB
  281. 58210 ' $SUBTITLE: 'REMOVE - subroutine to delete a string from within a string'
  282. ' $PAGE
  283. '
  284. '  NAME    -- REMOVE
  285. '
  286. '  INPUTS  -- PARAMETER                      MEANING
  287. '             BADSTRING$              STRING CONTAINING CHARACTERS
  288. '                                     TO BE DELETED FROM "L$"
  289. '             L$                      STRING TO BE ALTERED
  290. '
  291. '  OUTPUTS -- L$                      WITH THE CHARACTERS IN
  292. '                                     "BADSTRING#" DELETED FROM IT
  293. '
  294. '  PURPOSE -- To remove all instances of the characters in
  295. '                        "BADSTRING$" from "L$"
  296. '
  297.       SUB REMOVE (L$,BADSTRNG$) STATIC
  298.       J = 0
  299.       FOR I=1 TO LEN(L$)
  300.          IF INSTR(BADSTRNG$,MID$(L$,I,1)) = 0 THEN _
  301.             J = J + 1 : _
  302.             MID$(L$,J,1) = MID$(L$,I,1)
  303.       NEXT I
  304.       L$ = LEFT$(L$,J)
  305.       END SUB
  306. '
  307. 58250 ' $SUBTITLE: 'SMARTTXT - smart text substitution'
  308. ' $PAGE
  309. '
  310. '  NAME    -- SMARTTXT   (WRITTEN BY DOUG AZZARITO)
  311. '
  312. '  INPUTS  -- STRNG.WORK$        string to scan for Smart Text
  313. '             CR.FOUND           Does this line contain a CR?
  314. '             SMART.TEXT         Smart Text control code
  315. '
  316. '  OUTPUTS -- STRNG.WORK$        Input string with Smart replaced
  317. '
  318. '  PURPOSE -- Smart Text allows control strings in text files
  319. '             to be replaced at runtime with user info or other
  320. '             data.  The Smart Text control code is a 1-byte
  321. '             code (configurable) with a 2-byte action code.
  322. '
  323.       SUB SMARTTXT (STRNG.WORK$, CR.FOUND, OVERSTRIKE) STATIC
  324.       IF SMART.CARRY$<>"" THEN _
  325.          STRNG.WORK$ = SMART.CARRY$+STRNG.WORK$
  326.       INDEX = INSTR(STRNG.WORK$, SMART.TEXT$)
  327.       WHILE INDEX > 0 AND INDEX < LEN(STRNG.WORK$)-1
  328.          IF INSTR(MID$(STRNG.WORK$, INDEX+1,2)," ") THEN _
  329.             SMART.ACT = 0 _
  330.          ELSE _
  331.             SMART.ACT = INSTR(SMART.TABLE$, MID$(STRNG.WORK$, INDEX+1, 2))
  332.          IF SMART.ACT > 0 THEN _
  333.             SMART.ACT = (SMART.ACT+2)/3 : _
  334.             ON SMART.ACT GOSUB 58260, 58261, 58262, 58263, 58264, 58265, _
  335.                          58266, 58267, 58268, 58269, 58270, _
  336.                          58271, 58272, 58273, 58274, 58275, _
  337.                          58276, 58277, 58278, 58279, 58280, _
  338.                          58281, 58282, 58283, 58284, 58285 : _
  339.             IF OVERSTRIKE THEN _
  340.                MID$(STRNG.WORK$,INDEX) = SMART.HOLD$ _
  341.             ELSE STRNG.WORK$ = LEFT$(STRNG.WORK$, INDEX-1) + SMART.HOLD$ + _
  342.                                MID$(STRNG.WORK$,INDEX+3)
  343.          INDEX = INSTR(INDEX+1, STRNG.WORK$, CHR$(SMART.TEXT))
  344.       WEND
  345.       IF INDEX AND (INDEX > LEN(STRNG.WORK$)-2) AND NOT CR.FOUND THEN _
  346.          SMART.CARRY$ = MID$(STRNG.WORK$,INDEX) : _
  347.          STRNG.WORK$ = LEFT$(STRNG.WORK$,INDEX-1) : _
  348.       ELSE _
  349.          SMART.CARRY$ = ""
  350.       EXIT SUB
  351. 58258 LAST.SMART.COLOR$ = SMART.HOLD$                                ' MZ060302
  352.       RETURN                                                         ' MZ060302
  353. 58260 LINES.PRINTED = 0                     ' CS (Clear screen line count reset)
  354.       SMART.HOLD$ = ""
  355.       RETURN
  356. 58261 LINES.PRINTED = PAGE.LENGTH           ' PB Page Break
  357.       IF NON.STOP THEN _                    ' force a 1-time pause
  358.          ONE.STOP = TRUE : _                ' if NON STOP is on
  359.          NON.STOP = FALSE
  360.       SMART.HOLD$ = ""
  361.       FORCE.KEYBOARD = TRUE
  362.       RETURN
  363. 58262 NON.STOP = TRUE                       ' NS Non-stop
  364.       SMART.HOLD$ = ""
  365.       RETURN
  366. 58263 IF GLOBAL.SYSOP THEN _       'FN First Name
  367.          SMART.HOLD$ = ORIG.SYSOP.FN$ _
  368.       ELSE SMART.HOLD$ = FIRST.NAME$
  369.       RETURN
  370. 58264 IF GLOBAL.SYSOP THEN _
  371.          SMART.HOLD$ = ORIG.SYSOP.LN$ _
  372.       ELSE SMART.HOLD$ = LAST.NAME$
  373.       RETURN
  374. 58265 SMART.HOLD$ = MID$(STR$(USER.SECURITY.LEVEL),2)   ' SL Security level
  375.       RETURN
  376. 58266 SMART.HOLD$ = DATE$
  377.       RETURN
  378. 58267 CALL AMORPM                                                    ' KG061203
  379.       SMART.HOLD$ = TIM$
  380.       RETURN
  381. 58268 CALL TIMEREMAIN(TIME.REMAINING!)      ' TR Time remaining (in mins)
  382.       SMART.HOLD$ = MID$(STR$(INT(TIME.REMAINING!)),2)
  383.       RETURN
  384. 58269 CALL TIMEREMAIN(TIME.REMAINING!)      ' TE Time elapsed (mm:ss)
  385.       SMART.HOLD$ = MID$(STR$(INT(TCA!/60)),2)+":"+ MID$(STR$((TCA! MOD 60)+100),3)
  386.       RETURN
  387. 58270 SMART.HOLD$ = MID$(STR$(INT((TIME.LOCK.SET+0.5)/60)),2) ' TL - Time Lock period
  388.       SMART.HOLD$ = SMART.HOLD$ + ":"+ MID$(STR$((TIME.LOCK.SET MOD 60)+100),3)
  389.       RETURN
  390. 58271 SMART.HOLD$ = MID$(STR$(DAYS.IN.REGISTRATION.PERIOD),2)
  391.       RETURN                                ' RP Registration Length
  392. 58272 SMART.HOLD$ = MID$(STR$(REG.DAYS.REMAINING),2)
  393.       RETURN                                ' RR Registration Remaining
  394. 58273 SMART.HOLD$ = CITY.STATE$             ' CT Users CITY & STATE
  395.       RETURN
  396. 58274 SMART.HOLD$ = FG.1$                   ' C1 Color 1
  397.       GOTO 58258                                                     ' MZ060302
  398. 58275 SMART.HOLD$ = FG.2$                   ' C2 Color 2
  399.       GOTO 58258                                                     ' MZ060302
  400. 58276 SMART.HOLD$ = FG.3$                   ' C3 Color 3
  401.       GOTO 58258                                                     ' MZ060302
  402. 58277 SMART.HOLD$ = FG.4$                   ' C4 Color 4
  403.       GOTO 58258                                                     ' MZ060302
  404. 58278 SMART.HOLD$ = EMPHASIZE.OFF$          ' C0 Reset color
  405.       LAST.SMART.COLOR$ = ""                                         ' MZ060302
  406.       RETURN
  407. 58279 SMART.HOLD$ = MID$(STR$(INT(DL.TODAY!)),2)
  408.       RETURN                                ' DD files Dnlded TODAY
  409. 58280 SMART.HOLD$ = MID$(STR$(INT(BYTES.TODAY!)),2)
  410.       RETURN                                ' BD Bytes Dnlded TODAY
  411. 58281 SMART.HOLD$ = MID$(STR$(INT(DLBYTES!)),2)
  412.       RETURN                                ' DB Download Bytes
  413. 58282 SMART.HOLD$ = MID$(STR$(INT(ULBYTES!)),2)
  414.       RETURN                                ' UB Upload Bytes
  415. 58283 SMART.HOLD$ = MID$(STR$(DOWNLOADS),2) ' DL Number of Dnlds
  416.       RETURN
  417. 58284 SMART.HOLD$ = MID$(STR$(UPLOADS),2)   ' UL Number of Uplds
  418.       RETURN
  419. 58285 SMART.HOLD$ = FILE.NAME$              ' FILE NAME
  420.       END SUB
  421. '
  422. 58300 ' $SUBTITLE: 'BUFSTRNG - write a string with imbedded CR/LF'
  423. ' $PAGE
  424. '
  425. '  NAME    -- BUFSTRNG
  426. '
  427. '  INPUTS  -- PARAMETER                      MEANING
  428. '             STRNG$                  STRING TO BE WRITTEN OUT
  429. '             DATA.SIZE               LENGTH OF STRING - # LEFT
  430. '                                        CHARS TO OUTPUT
  431. '
  432. '  OUTPUTS -- STRNG$                  IS WRITTEN TO THE USER
  433. '
  434. '  PURPOSE -- To search the string, STRNG$, for embedded carriage
  435. '             returns and line feeds and write out each line with
  436. '             the appropriate substitution (cr/lf if to the local
  437. '             screen or cr/nulls/lf if to the communications port).
  438. '
  439.       SUB BUFSTRNG (STRNG$,PASSED.DATA.SIZE,ABORT.INDEX) STATIC
  440.       L = LEN(STRNG$)
  441.       IF PASSED.DATA.SIZE < L THEN _
  442.          L = PASSED.DATA.SIZE
  443.       IF L < 1 THEN _
  444.          EXIT SUB
  445.       FF = PAGE.LENGTH - 1
  446.       START.BYTE = 1
  447.       IF CARRY.OVER THEN _
  448.          IF ASC(STRNG$) = 10 THEN _
  449.             START.BYTE = 2 : _
  450.             CALL SKIPLINE (1)
  451.       CARRY.OVER = (MID$(STRNG$,L,1) = CARRIAGE.RETURN$)
  452.       L = L + CARRY.OVER
  453. 58301 CRAT = INSTR(START.BYTE,STRNG$,CARRIAGE.RETURN$)
  454.       IF CRAT > 0 AND CRAT < L THEN _
  455.          CR.FOUND = (MID$(STRNG$,CRAT + 1,1) = LINE.FEED$) _
  456.       ELSE CR.FOUND = FALSE
  457.       EOL.LEN = -2 * CR.FOUND
  458.       IF CR.FOUND THEN _
  459.          EOD = CRAT _
  460.       ELSE EOD = L + 1
  461.       NUM.BYTES = EOD - START.BYTE
  462.       STRNG.WORK$ = MID$(STRNG$,START.BYTE,NUM.BYTES)
  463.       IF NOT DELETE.INVALID THEN _
  464.          GOTO 58304
  465.       INDEX = INSTR(STRNG.WORK$,"[")
  466.       J = LEN(STRNG.WORK$) - 1
  467.       WHILE INDEX > 0 AND INDEX < J
  468.          IF MID$(STRNG.WORK$,INDEX + 2,1) = "]" THEN _
  469.             IF INSTR (INVALID.OPTS$,MID$(STRNG.WORK$,INDEX + 1,1)) THEN _
  470.                MID$(STRNG.WORK$,INDEX + 1,1) = "*"
  471.          INDEX = INSTR(INDEX + 1,STRNG.WORK$,"[")
  472.       WEND
  473. 58304 IF SMART.TEXT THEN _
  474.          CALL SMARTTXT (STRNG.WORK$, CR.FOUND, FALSE)
  475.       CALL QTPUT (STRNG.WORK$, - (CR.FOUND))
  476.       IF RET THEN _
  477.          EXIT SUB
  478.       IF LINES.PRINTED < FF THEN _
  479.          GOTO 58305
  480.       CALL CHKTREMAIN (TIME.REMAINING!)
  481.       CALL CHKCARRIER                                                ' KG061203
  482.       IF SUBROUTINE.PARAMETER = -1 THEN _
  483.          EXIT SUB
  484.       IF NON.STOP THEN _
  485.          GOTO 58305
  486.       IF NOT CR.FOUND THEN _                                         ' KG052002
  487.          GOTO 58305                                                  ' KG052002
  488.       CALL ASKMORE ("",TRUE,FALSE,ABORT.INDEX,STOP.INTERRUPTS)
  489.       IF NO THEN _
  490.          RET = TRUE : _
  491.          EXIT SUB
  492. 58305 START.BYTE = EOD + EOL.LEN
  493.       IF START.BYTE <= L THEN _
  494.          GOTO 58301
  495.       END SUB
  496. 58400 ' $SUBTITLE: 'BUFFILE - subroutine to write a sequential file to the user'
  497. ' $PAGE
  498. '
  499. '  NAME    -- BUFFILE
  500. '
  501. '  INPUTS  -- PARAMETER                      MEANING
  502. '             FILENAME$               NAME OF THE FILE TO WRITE TO
  503. '                                                OUT TO THE USER
  504. '
  505. '  OUTPUTS -- NONE                    FILE IS WRITTEN TO THE USER
  506. '
  507. '  PURPOSE -- To display a sequential file to the user
  508. '
  509.       SUB BUFFILE (FILNAME$,ABORT.INDEX) STATIC
  510.       CALL FINDIT (FILNAME$)
  511.       IF NOT OK THEN _
  512.          EXIT SUB
  513.       NO = FALSE
  514.       CALL OPENRSEQ (FILNAME$,NUM.RECS,LEN.LAST.REC,BUFFER.SIZE)
  515.       DATA.SIZE = BUFFER.SIZE
  516.       FIELD 2, DATA.SIZE AS SEQ.REC$
  517.       NON.STOP = NON.STOP OR (PAGE.LENGTH < 1)
  518.       IF NOT STOP.INTERRUPTS THEN _
  519.          IF NOT CONCAT.FILES THEN _
  520.             IF NOT NON.STOP THEN _
  521.                A$ = "* Ctrl-K(^K) / ^X aborts. ^S suspends ^Q resumes *" : _
  522.                SUBROUTINE.PARAMETER = 2 : _
  523.                CALL TPUT
  524.       TU = 0
  525. 58405 TU = TU + 1
  526.       IF TU < NUM.RECS THEN _
  527.          GET 2,TU _
  528.       ELSE IF TU = NUM.RECS THEN _
  529.               GET 2,TU : _
  530.               X = INSTR(SEQ.REC$,CHR$(26)) : _
  531.               IF X = 0 OR X > LEN.LAST.REC THEN _
  532.                  DATA.SIZE = LEN.LAST.REC _
  533.               ELSE DATA.SIZE = X - 1 _
  534.            ELSE GOTO 58419
  535.       IF LOCAL.USER THEN _
  536.          GOTO 58406
  537.       CALL EOFCOMM (CHAR%)
  538.       IF CHAR% <> -1 THEN _
  539.          GOTO 58407            ' comm port input
  540. 58406 KEYBOARD.STACK$ = INKEY$
  541.       IF KEYBOARD.STACK$ = "" THEN _  ' no keyboard input
  542.          CALL BUFSTRNG (SEQ.REC$,DATA.SIZE,ABORT.INDEX) : _
  543.          GOTO 58408
  544. 58407 A$ = LEFT$(SEQ.REC$,DATA.SIZE)  ' process comm/keyboard
  545.       SUBROUTINE.PARAMETER = 4
  546.       CALL TPUT
  547. 58408 IF SUBROUTINE.PARAMETER <> -1 AND NOT RET THEN _
  548.          GOTO 58405
  549. 58419 CLOSE 2
  550.       BYPASS.TIME.CHECK = FALSE
  551.       STOP.INTERRUPTS = FALSE
  552.       CALL QTPUT (EMPHASIZE.OFF$,0)
  553.       END SUB
  554. 58600 ' $SUBTITLE: 'FINDLAST - find last occurence of a string'
  555. ' $PAGE
  556. '
  557. '  NAME    -- FINDLAST
  558. '
  559. '  INPUTS  -- PARAMETER             MEANING
  560. '                        LOOK.IN$           STRING TO LOOK INTO
  561. '                        LOOK.FOR$          STRING TO SEARCH FOR
  562. '
  563. '  OUTPUTS -- WHERE.FOUND        POSITION IN LOOK.IN$ THAT
  564. '                                   LOOK.FOR$ FOUND
  565. '             NUM.FINDS          HOW MANY OCCURENCES IN LOOK.IN$
  566. '
  567. '  PURPOSE -- Finds last occurence of LOOK.FOR$ in LOOK.IN$ and
  568. '             returns count of # of occurences.  If none found,
  569. '             both returned parameters are set to 0.
  570. '
  571.       SUB FINDLAST (LOOK.IN$,LOOK.FOR$,WHERE.FOUND,NUM.FINDS) STATIC
  572.       WHERE.FOUND = INSTR(LOOK.IN$,LOOK.FOR$)
  573.       NUM.FINDS = -(WHERE.FOUND > 0)
  574.       NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$)
  575.       WHILE NEXT.FOUND > 0
  576.          NUM.FINDS = NUM.FINDS + 1
  577.          WHERE.FOUND = NEXT.FOUND
  578.          NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$)
  579.       WEND
  580.       END SUB
  581. 58700 ' $SUBTITLE: 'ROTORSDIR - search thru a list of subdirs for a file'
  582. ' $PAGE
  583. '
  584. '  NAME    -- ROTORSDIR
  585. '
  586. '  INPUTS  --     PARAMETER                    MEANING
  587. '             FILNAME$                  FILE NAME TO LOOK FOR
  588. '             SDIR.ARA                  ARRAY OF SUBDIRECTORIES
  589. '             MAX.SEARCH                MAX # OF SUBDIRECTORIES
  590. '             MARK.TIME                 WHETHER TO MARK TIME
  591. '
  592. '  OUTPUTS -- FNAME$                    ADD SUBDIRECTORY TO THE
  593. '                                       FILE NAME IF FOUND.  OTHER-
  594. '                                       WISE DON'T.
  595. '             OK                        TRUE IF FILE WAS FOUND
  596. '
  597. '  PURPOSE -- Hunt through a list of subdirectories to determine
  598. '             if a file is in any of them.  If file is found, open
  599. '             the file as file #2, add the drive/path to the file
  600. '             name, and sets OK to true.  If file isn't found, set
  601. '             file name to the last subdirectory searched -- which
  602. '             should be the upload subdirectory.
  603. '
  604. '             If the library menu is selected (MENU.INDEX = 6), then
  605. '             only 2 subdirectories are searched. The first being
  606. '             the work disk and the second being the selected
  607. '             library disk.
  608. '
  609.       SUB ROTORSDIR (FILNAME$,SDIR.ARA$(1),MAX.SEARCH,MARK.TIME) STATIC
  610.       OK = FALSE
  611.       IF MARK.TIME THEN _
  612.          CALL QTPUT ("Searching for "+FILNAME$,0)
  613.       IF MENU.INDEX = 6 THEN _
  614.          GOTO 58705
  615.       NUM.SEARCH = 1
  616.       X = 0
  617.       WHILE (NOT OK) AND NUM.SEARCH <= MAX.SEARCH AND _
  618.          SDIR.ARA$(NUM.SEARCH) <> ""
  619.          IF MARK.TIME THEN _
  620.             CALL MARKTIME (X)
  621.          X$ = SDIR.ARA$(NUM.SEARCH) + _
  622.               FILNAME$
  623.          CALL FINDIT (X$)
  624.          NUM.SEARCH = NUM.SEARCH + 1
  625.       WEND
  626.       GOTO 58710
  627. 58705 X$ = LIBRARY.WORK.DISK.PATH$ + _
  628.            FILNAME$
  629.       CALL FINDIT (X$)
  630.       IF OK THEN _
  631.          GOTO 58710
  632.       X$ = LIBRARY.DRIVE$ + _
  633.            FILNAME$
  634.       CALL FINDIT (X$)
  635. 58710 FILNAME$ = X$
  636.       CALL SKIPLINE (-MARK.TIME)
  637.       END SUB
  638. 58800 ' $SUBTITLE: 'WIPELINE - Wipe away a line so next overprints'
  639. ' $PAGE
  640. '
  641. '  NAME    -- WIPELINE
  642. '
  643. '  INPUTS  --     PARAMETER                    MEANING
  644. '                 CARRIAGE.RETURN$
  645. '                 CHARS.TO.WIPE            # OF CHARACTERS TO BLANK
  646. '                 NULLS
  647. '
  648. '  OUTPUTS -- NONE
  649. '
  650. '  PURPOSE -- Wipe away a line and leave cursor at beginning of the
  651. '             same line so that the next line will print in its place
  652. '
  653.       SUB WIPELINE (CHARS.TO.WIPE) STATIC
  654.       IF NULLS OR CHARS.TO.WIPE > 79 THEN _
  655.          CALL SKIPLINE (1) : _
  656.          EXIT SUB
  657.       IF NOT LOCAL.USER THEN _
  658.          STRNG$ = CARRIAGE.RETURN$ + SPACE$(CHARS.TO.WIPE) + CARRIAGE.RETURN$ : _
  659.          IF FOSSIL THEN _
  660.             BYTES% = LEN(STRNG$) : _
  661.             CALL FOSWRITE(COMPORT%,BYTES%,STRNG$) _
  662.          ELSE PRINT #3,STRNG$
  663.       IF SNOOP THEN _
  664.          LOCATE ,1 :  _
  665.          CALL LPRNT(SPACE$(CHARS.TO.WIPE),0) : _
  666.          LOCATE ,1
  667.       IF F7.MESSAGE$ = "" OR _
  668.          F7.MESSAGE$ = "NONE" OR _
  669.          NOT SYSOP.NEXT THEN _
  670.          EXIT SUB
  671.       BYPASS.TIME.CHECK = TRUE
  672.       CALL BUFFILE (F7.MESSAGE$,X)
  673.       END SUB
  674. 58895 ' $SUBTITLE: 'GETDIRS -- Prompt for directories to search'
  675. ' $PAGE
  676. '
  677. '  NAME    -- GETDIRS
  678. '
  679. '  INPUTS  --     PARAMETER                    MEANING
  680. '                 DIR.PROMPT$             BASE OF DIRECTORY PROMPT
  681. '                 SHOW.HELP               Whether to display help
  682. '                                            on entry
  683. '  OUTPUTS --     B$
  684. '                 Q
  685. '
  686. '  PURPOSE -- Prompt for directories to search
  687. '
  688.       SUB GETDIRS (SHOW.HELP) STATIC
  689.       IF SHOW.HELP THEN _
  690.          GOTO 58902
  691. 58900 A$ = DIR.PROMPT$
  692.       MACRO.MIN = 2
  693.       SUBROUTINE.PARAMETER = 1
  694.       CALL TGET
  695.       IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _
  696.          EXIT SUB
  697.       CALL ALLCAPS (B$(1))
  698.       IF B$(1) = "Q" THEN _
  699.          Q = 0 : _
  700.          EXIT SUB
  701.       A = INSTR("E+.E-.E.L.H.?.",B$(1)+".")
  702.       IF A = 0 THEN _
  703.          EXIT SUB
  704.       IF A > 8 THEN _
  705.          GOTO 58901
  706.       IF A = 7 THEN _
  707.          EXTENDED.OFF = NOT EXTENDED.OFF _
  708.       ELSE EXTENDED.OFF = (A > 3)
  709.       CALL QTPUT1 ("Extended directory display "+MID$("ON OFF",1-3*EXTENDED.OFF,3))
  710.       GOTO 58900
  711. 58901 IF A = 9 AND Q > 1 THEN _
  712.          Q = Q - 1 : _
  713.          FOR B = 1 TO Q : _
  714.             B$(B) = B$(B + 1) : _
  715.          NEXT : _
  716.          EXIT SUB
  717. 58902 FILE.NAME$ = DIRECTORY.PATH$ + DIRECTORY.PREFIX$ + _
  718.                     "." + DIRECTORY.EXTENTION$
  719.       GDEFAULT$ = MID$(" GC",GR + 1, 1)
  720.       CALL GRAPHIC (GDEFAULT$,FILE.NAME$)
  721.       CALL BUFFILE (FILE.NAME$,X)
  722.       GOTO 58900
  723.       END SUB
  724. '
  725. 58950 ' $SUBTITLE: 'CONVDIRS -- Converts coded response to right directory'
  726. ' $PAGE
  727. '
  728. '  NAME    -- CONVDIRS
  729. '
  730. '  INPUTS  --     PARAMETER                    MEANING
  731. '                 STRT               ELEMENT TO BEGIN WITH
  732. '                 B$                 ARRAY TO CONVERT
  733. '                 Q                  LAST ELEMENT TO CONVERT
  734. '
  735. '  OUTPUTS --     B$                 CONVERTED DIRECTORY LIST
  736. '
  737. '  PURPOSE -- Let the user put in a short standard string for a directory
  738. '
  739. '
  740.       SUB CONVDIRS (STRT) STATIC
  741.       FOR I=STRT TO Q
  742.          CALL ALLCAPS (B$(I))
  743.          IF B$(I)="U" THEN _
  744.             B$(I) = UPLOAD.DIR.CHECK$
  745.          IF B$(I) = "A" THEN _
  746.             B$(I) = "ALL"
  747.       NEXT
  748.       END SUB
  749. 59100 ' $SUBTITLE: 'MUZAK - subroutine to PLAY MUSIC'
  750. ' $PAGE
  751. '
  752. '  NAME    -- MUZAK
  753. '
  754. '  INPUTS  --   PARAMETER     MEANING
  755. '                       1   PLAY CONSIDER YOURSELF(OPENING SCREEN)
  756. '                       2   PLAY WALK RIGHT IN(NEW USERS)
  757. '                       3   PLAY DRAGNET (SECURITY VIOLATION)
  758. '                       4   PLAY GOODBYE CHARLIE (GOODBYE)
  759. '                       5   PLAY TAPS (ACCESS DENIED)
  760. '                       6   PLAY OOM PAH PAH (DOWNLOAD)
  761. '                       7   PLAY THNKS FOR MEMORIES(UPLOAD)
  762. '
  763. '  OUTPUTS -- NONE
  764. '
  765. '  PURPOSE -- Provide sysops and the visually impaired with
  766. '             auditory feedback on what RBBS-PC is doing
  767. '
  768.       SUB MUZAK (PASSED.ARG) STATIC
  769.       FF = PASSED.ARG
  770.       SUBROUTINE.PARAMETER = 0
  771.       IF (NOT SNOOP) OR (NOT MUSIC) OR LOCAL.USER.MODE THEN _
  772.          EXIT SUB
  773.       ON FF GOTO 59102,59104,59106,59108,59110,59112,59114
  774.       EXIT SUB
  775. 59102 '---[Introduction CONSIDER YOURSELF]---
  776.     LEC$ = "MBT180A4B-8B-8B-8B-2.G4A8F2"
  777.     PLAY "O2 X" + VARPTR$(LEC$)
  778.     EXIT SUB
  779. 59104 '---[New User WALK RIGHT IN]---
  780.     LEC1$ = "MBT180G4G4D2G8F+8F8E2A8B8"
  781.     LEC2$ = "C8C+8D8C8"
  782.     LEC3$ = "B4G2"
  783.     PLAY "O2 X" + VARPTR$(LEC1$) + "O3 X" + VARPTR$(LEC2$) + "O2 X" + VARPTR$(LEC3$)
  784.     EXIT SUB
  785. 59106 '---[Security Violation DRAGNET THEME]---
  786.      LEC$ = "MBT120C2D8E-4C2.C2D8E-4C4G-2."
  787.      PLAY "O2 X" + VARPTR$(LEC$)
  788.      EXIT SUB
  789. 59108 '---[Goodbye GOODBYE CHARLIE]---
  790.       LEC$ = "MBT180B-2.G2.F4D2."
  791.       PLAY "O2 X" + VARPTR$(LEC$)
  792.       EXIT SUB
  793. 59110 '---[Access Denied TAPS]---
  794.       LEC1$ = "MBT90F8A16"
  795.       LEC2$ = "C4."
  796.       LEC3$ = "A4F4C2.C8C16F2"
  797.       PLAY "O2 X" + VARPTR$(LEC1$) + "O3 X" + VARPTR$(LEC2$) + "O2 X" + VARPTR$(LEC3$)
  798.       EXIT SUB
  799. 59112 '---[Download OOM PAH PAH]---
  800.        LEC$ = "MBT180F4A4A4C4A4A4G4A4G4D2"
  801.        PLAY "O2 X" + VARPTR$(LEC$)
  802.        EXIT SUB
  803. 59114 '---[Upload THANKS FOR THE MEMORIES]---
  804.        LEC1$ = "MBT180C2."
  805.        LEC2$ = "A8G8F4D2"
  806.        PLAY "O3 X" + VARPTR$(LEC1$) + "O2 X" + VARPTR$(LEC2$)
  807.        END SUB
  808. 59200 ' $SUBTITLE: 'TWOBYTEDATE -- subroutine to put date in 2 bytes'
  809. ' $PAGE
  810. '
  811. '  NAME    -- TWOBYTEDATE
  812. '
  813. '  INPUTS  --   PARAMETER     MEANING
  814. '                  YY       FOUR DIGIT YEAR (I.E. 1987)
  815. '                  MM       MONTH
  816. '                  DD       DAY
  817. '                RESULT$    LOCATION TO PLACE THE RESULT
  818. '
  819. '  OUTPUTS -- RESULT$       TWO BYTE COMPRESSED DATE FOR USE IN
  820. '                           A RANDOM RECORD
  821. '
  822. '  PURPOSE -- Compress a Y,M,D date into two characters
  823. '
  824.       SUB TWOBYTEDATE (YY,MM,DD,RESULT$) STATIC
  825.       RESULT$ = CHR$(((YY - 1980) * 2) OR - ((MM AND 8) <> 0)) + _
  826.                 CHR$((MM AND NOT 8) * 32 + DD)
  827.       END SUB
  828. 59201 ' $SUBTITLE: 'CSTRDATE -- subroutine to Compress STRing DATE'
  829. ' $PAGE
  830. '
  831. '  NAME    -- CSTRDATE
  832. '
  833. '  INPUTS  --   PARAMETER     MEANING
  834. '                 STRNG$    String Date (mm-dd-yyyy)
  835. '
  836. '  OUTPUTS --    RESULT$    TWO BYTE COMPRESSED DATE FOR USE IN
  837. '                                      A RANDOM RECORD
  838. '
  839. '  PURPOSE -- Compress an 8-character date into two characters
  840. '
  841.       SUB CSTRDATE (STRNG$,RESULT$) STATIC
  842.       IF LEN(STRNG$) < 8 THEN _
  843.          EXIT SUB
  844.       YY = VAL(MID$(STRNG$,7))
  845.       MM = VAL(STRNG$)
  846.       DD = VAL(MID$(STRNG$,4))
  847.       CALL TWOBYTEDATE (YY,MM,DD,RESULT$)
  848.       END SUB
  849. 59202 ' $SUBTITLE: 'UNCDATE -- subroutine to UNCompress DATE'
  850. ' $PAGE
  851. '
  852. '  NAME    -- UNCDATE
  853. '
  854. '  INPUTS  --   PARAMETER      MEANING
  855. '             COMPRESSED.DATE$ Date in 2 byte compressed form
  856. '
  857. '  OUTPUTS --     YY           Year of compressed date
  858. '                 MM           Month of compressed date
  859. '                 DD           Day of compressed date
  860. '             DISPLAY.DATE$    8 char display date (mm-dd-yyyy)
  861. '
  862. '  PURPOSE -- Uncompress a 2 char date to get Y,M,D & display
  863. '
  864.       SUB UNCDATE (COMPRESSED.DATE$,YY,MM,DD,DISPLAY.DATE$) STATIC
  865.       CALL GETYMD (COMPRESSED.DATE$,1,YY)
  866.       CALL GETYMD (COMPRESSED.DATE$,2,MM)
  867.       CALL GETYMD (COMPRESSED.DATE$,3,DD)
  868.       DISPLAY.DATE$ = RIGHT$("00" + MID$(STR$(MM),2),2) + _
  869.                       "-" + _
  870.                       RIGHT$("00" + MID$(STR$(DD),2),2) + _
  871.                       "-" + _
  872.                       RIGHT$(STR$(YY),2)
  873.       END SUB
  874. 59204 ' $SUBTITLE: 'GETYMD -- subroutine to unpack a two-byte date'
  875. ' $PAGE
  876. '
  877. '  NAME    -- GETYMD
  878. '
  879. '  INPUTS  --   PARAMETER     MEANING
  880. '                 TWOBYTE$    PACKED TWO-BYTE DATE FIELD
  881. '                   YMD       1 = YEAR
  882. '                             2 = MONTH
  883. '                             3 = DAY
  884. '                 RESULT      LOCATION TO PLACE THE RESULT
  885. '
  886. '  OUTPUTS -- RESULT        FOUR DIGIT RESULT OF UNPAKING THE DATE
  887. '
  888. '  PURPOSE -- Unpack a compressed two-byte date field
  889. '
  890.       SUB GETYMD (TWOBYTE$,YMD,RESULT) STATIC
  891.       ON YMD GOTO 59206,59210,59215
  892.       EXIT SUB
  893. 59206 RESULT = (ASC(TWOBYTE$)AND NOT 1) / 2 + 1980
  894.       EXIT SUB
  895. 59210 RESULT = FIX((ASC(MID$(TWOBYTE$,2)) / 32)) OR ((ASC(TWOBYTE$) AND 1) * 8)
  896.       EXIT SUB
  897. 59215 RESULT = ASC(MID$(TWOBYTE$,2)) AND NOT 224
  898.       END SUB
  899. 59300 ' $SUBTITLE: 'PERSFILE - processes requests for personal files'
  900. ' $PAGE
  901. '
  902. '  NAME    -- PERSFILE
  903. '
  904. '  INPUTS  --     PARAMETER           MEANING
  905. '                            PERSONAL.CAT$     CATEGORY IN DIR FOR CALLER
  906. '                            PERSONAL.LEN      # CHARS IN PERSONAL CATEGORY
  907. '  OUTPUTS -- NONE UP DOWNLOADS
  908. '
  909. '  PURPOSE -- Show caller what personal files have for downloading,
  910. '             verify and process requests for downloads
  911. '
  912.       SUB PERSFILE (PERSONAL.CAT$,DOWNLOAD.FLAG) STATIC
  913.       CALL FINDIT (PERSONAL.DIR$)
  914. 59302 IF NOT OK THEN _
  915.          CALL QTPUT1 ("No personal files available") : _
  916.          Q = 0 : _
  917.          EXIT SUB
  918.       L = 36 + MAX.DESC.LEN + PERSONAL.LEN
  919.       IF LOF(2) < L THEN _
  920.         OK = FALSE : _
  921.         GOTO 59302
  922.       B$(0) = ""
  923.       CLOSE 2
  924.       IF SHARE.IT THEN _
  925.          OPEN PERSONAL.DIR$ FOR RANDOM SHARED AS #2 LEN=L _
  926.       ELSE OPEN "R",2,PERSONAL.DIR$,L
  927.       FIELD #2,33 + MAX.DESC.LEN AS PART.TO.PRINT$, _
  928.                PERSONAL.LEN    AS PRIVATE.CAT$, _
  929.                1               AS PERSONAL.STATUS$, _
  930.                2               AS FILLER$
  931.       MAX.PRINT = PAGE.LENGTH - 1
  932.       NON.STOP = NON.STOP OR (PAGE.LENGTH < 1)
  933.       LAST.REC = LOF(2) / L
  934.       IF DOWNLOADING THEN _
  935.          DOWNLOADING = FALSE : _
  936.          PERS.INDEX = DOWNLOAD.FLAG : _
  937.          DOWNLOAD.FLAG = 0 : _
  938.          GOTO 59306
  939.       IF Q > 1 THEN _
  940.          FOR I = 2 TO Q : _
  941.             B$(I - 1) = B$(I) : _
  942.          NEXT : _
  943.          Q = Q - 1 : _
  944.          GOTO 59304
  945. 59303 A$ = "Download what: L)ist, * = new, or file(s)" + _
  946.            PRESS.ENTER.EXPERT$
  947.       SUBROUTINE.PARAMETER = 1
  948.       MACRO.MIN = 99
  949.       CALL TGET
  950.       IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _
  951.          EXIT SUB
  952. 59304 SELECTED.PROTOCOL$ = ""
  953.       IF Q > 1 THEN _
  954.          IF LEN(B$(Q)) = 1 THEN _
  955.             SELECTED.PROTOCOL$ = B$(Q) : _
  956.             Q = Q - 1
  957.       IF LEN(B$(1)) > 2 THEN _
  958.          GOTO 59330
  959.       CALL ALLCAPS (B$(1))
  960.       ON INSTR("L*",B$(1)) GOTO 59305,59327
  961.       GOTO 59303
  962. 59305 PERS.INDEX = LAST.REC
  963.       L = FALSE
  964. 59306 IF PERS.INDEX < 1 THEN _
  965.          IF L THEN _
  966.             GOTO 59303 _
  967.          ELSE _
  968.             A$ = "No files for you" : _
  969.                  CALL QTPUT1 (A$) : _
  970.               GOTO 59303
  971.       GET #2,PERS.INDEX
  972.       PERS.INDEX = PERS.INDEX - 1
  973.       IF SYSOP THEN _
  974.          GOTO 59320
  975.       IF ASC(PRIVATE.CAT$) = 32 THEN _
  976.          IF USER.SECURITY.LEVEL < VAL(PRIVATE.CAT$) THEN _
  977.             GOTO 59306 _
  978.          ELSE GOTO 59308
  979.       IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _
  980.          GOTO 59306
  981. 59308 L = TRUE
  982.       FILNAME$ = PERSONAL.DRVPATH$ + _
  983.                  LEFT$(PART.TO.PRINT$,12)
  984. 59320 A$ = PART.TO.PRINT$                                            ' KG052003
  985.       CALL COLORDIR (A$,"Y")                                         ' KG052003
  986.       IF PERSONAL.STATUS$ = "*" AND LEFT$(A$,1) <> " " THEN _        ' KG052003
  987.          A$ = "*" + A$ _                                             ' KG052003
  988.       ELSE A$ = " " + A$                                             ' KG052003
  989.       IF LOCAL.USER THEN _
  990.          GOTO 59322
  991.       CALL EOFCOMM (CHAR%)
  992.       IF CHAR% <> -1 THEN _
  993.          GOTO 59323            ' comm port input
  994. 59322 KEYBOARD.STACK$ = INKEY$
  995.       IF KEYBOARD.STACK$ = "" THEN _  ' no keyboard input
  996.          CALL QTPUT1 (A$) : _
  997.          GOTO 59324
  998. 59323 SUBROUTINE.PARAMETER = 1
  999.       CALL TPUT
  1000.       IF RET THEN _
  1001.          GOTO 59303
  1002.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1003.          GOTO 59335
  1004. 59324 IF LINES.PRINTED <= MAX.PRINT THEN _
  1005.          GOTO 59306
  1006.       CALL TIMEREMAIN (TIME.REMAINING!)
  1007.       IF TIME.REMAINING! < 0.1 THEN _
  1008.          SUBROUTINE.PARAMETER = -1 : _
  1009.          GOTO 59335
  1010.       CALL CARRIER
  1011.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1012.          GOTO 59335
  1013.       IF NON.STOP THEN _
  1014.          GOTO 59306
  1015. 59325 IF PERS.INDEX > 0 THEN _
  1016.          A$ = "MORE: [Y],N,C or download what (* = new)" _
  1017.       ELSE GOTO 59303
  1018.       SUBROUTINE.PARAMETER = 1
  1019.       NO.ADVANCE = TRUE
  1020.       MACRO.MIN = 99
  1021.       CALL TGET
  1022.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1023.          GOTO 59335
  1024.       NON.STOP = (NON.STOP OR INSTR(" Cc",B$) > 1)
  1025.       IF PERS.INDEX < 1 AND Q = 0 THEN _
  1026.          GOTO 59335
  1027.       CALL WIPELINE (78)
  1028.       IF NO THEN _
  1029.          GOTO 59303
  1030.       IF LEN(B$(1)) > 2 THEN _
  1031.          GOTO 59304
  1032.       GOTO 59306
  1033. 59327 PERS.INDEX = LAST.REC        ' handle new files
  1034.       Q = 0
  1035.       WHILE PERS.INDEX > 0 AND  Q < UBOUND(B$)
  1036.          GET 2,PERS.INDEX
  1037.          IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _
  1038.             GOTO 59329
  1039.          IF PERSONAL.STATUS$ <> "*" THEN _
  1040.             GOTO 59329
  1041.          Q = Q + 1
  1042.          I = Q
  1043.          GOSUB 59336
  1044.          IF OK THEN _
  1045.             X$ = MID$(STR$(PERS.INDEX),2) : _
  1046.             B$(0) = B$(0) + _
  1047.                     X$ + _
  1048.                     SPACE$(5 - LEN(X$)) _
  1049.          ELSE Q = Q - 1
  1050. 59329    PERS.INDEX = PERS.INDEX - 1
  1051.       WEND
  1052.       IF Q = 0 THEN _
  1053.          A$ = "No new files for you" : _
  1054.          CALL QTPUT1 (A$) : _
  1055.          GOTO 59303
  1056.       GOTO 59332
  1057. 59330 I = 1              ' handle list of files
  1058.       WHILE I <= Q
  1059.          OK = FALSE
  1060.          J = LAST.REC + 1
  1061.          CALL ALLCAPS (B$(I))
  1062.          WHILE J > 1 AND NOT OK
  1063.             J = J - 1
  1064.             GET #2,J
  1065.             IF (PERSONAL.CAT$ = PRIVATE.CAT$ OR _
  1066.                (ASC(PRIVATE.CAT$) = 32 AND _
  1067.                 USER.SECURITY.LEVEL => VAL(PRIVATE.CAT$))) THEN _
  1068.                    OK = (B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1))
  1069.          WEND
  1070.          IF OK THEN _
  1071.             GOSUB 59336 : _
  1072.             IF OK THEN _
  1073.                X$ = MID$(STR$(J),2) : _
  1074.                B$(0) = B$(0) + _
  1075.                        X$ + _
  1076.                        SPACE$(5 - LEN(X$))
  1077.          IF NOT OK THEN _
  1078.             CALL QTPUT1 (B$(I) + " not found - omitted") : _
  1079.             FOR K = I + 1 TO Q : _
  1080.                B$(K - 1) = B$(K) : _
  1081.             NEXT : _
  1082.             Q = Q - 1 : _
  1083.             I = I - 1
  1084.          I = I + 1
  1085.       WEND
  1086.       IF Q = 0 THEN _
  1087.          GOTO 59303
  1088. 59332 DOWNLOAD.FLAG = PERS.INDEX          ' set protocol
  1089.       DOWNLOADING = TRUE
  1090.       B = 1
  1091.       IF SELECTED.PROTOCOL$ = "" THEN _
  1092.          IF PERSONAL.PROTOCOL$ <> " " THEN _
  1093.             SELECTED.PROTOCOL$ = PERSONAL.PROTOCOL$
  1094.       IF SELECTED.PROTOCOL$ <> "" THEN _
  1095.          Q = Q + 1 : _
  1096.          B$(Q) = SELECTED.PROTOCOL$
  1097.       EXIT SUB
  1098.  
  1099. 59335 CLOSE 2
  1100.       EXIT SUB
  1101. 59336 B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1)
  1102.       CALL RBBSFIND (PERSONAL.DRVPATH$ + B$(I),Z,K,L,M)
  1103.       OK = (Z = 0)
  1104.       IF OK THEN _
  1105.          B$(I) = PERSONAL.DRVPATH$ + B$(I) _
  1106.       ELSE K = 0 : _
  1107.            WHILE K < SUBDIR.COUNT AND NOT OK : _
  1108.               K = K + 1 : _
  1109.               CALL RBBSFIND (SUBDIR$(K) + B$(I),Z,X,L,M) : _
  1110.               OK = (Z=0) : _
  1111.            WEND : _
  1112.            IF OK THEN _
  1113.               B$(I) = SUBDIR$(K) + B$(I)
  1114.       RETURN
  1115.       END SUB
  1116. 59400 ' $SUBTITLE: 'LOGDOWN -- subroutine to record private downloads'
  1117. ' $PAGE
  1118. '
  1119. '  NAME    -- LOGDOWN
  1120. '
  1121. '  INPUTS  --   PARAMETER     MEANING
  1122. '
  1123. '  OUTPUTS --
  1124. '
  1125. '  PURPOSE -- Puts a "!" in place of an "*" in private directory
  1126. '             after downloaded
  1127. '
  1128.       SUB LOGDOWN (PRIVATE.DOWNLOAD,DWN.INDEX) STATIC
  1129.       IF NOT PRIVATE.DOWNLOAD THEN _
  1130.          EXIT SUB
  1131.       EN$ = PERSONAL.DIR$
  1132.       BX = &H4
  1133.       SUBROUTINE.PARAMETER = 9
  1134.       CALL FILELOCK
  1135.       L = 36 + MAX.DESC.LEN + PERSONAL.LEN
  1136.       CLOSE 2
  1137.       IF SHARE.IT THEN _
  1138.          OPEN EN$ FOR RANDOM SHARED AS #2 LEN=L _
  1139.       ELSE OPEN "R",2,PERSONAL.DIR$,L
  1140.       FIELD #2,L AS PERSONAL.REC$
  1141.       A = VAL(MID$(B$(0),5 * (DWN.INDEX - 1) + 1,5))
  1142.       GET #2,A
  1143.       MID$(PERSONAL.REC$,L-2,1) = "!"
  1144.       PUT #2,A
  1145.       CALL UNLKAPPND
  1146.       END SUB
  1147. 59450 ' $SUBTITLE: 'USERFACE - handles programmable user interface'
  1148. ' $PAGE
  1149. '
  1150. '  NAME    --  USERFACE
  1151. '
  1152. '  INPUTS  --  PARAMETER                   MEANING
  1153. '              GDEFAULT$            GRAPHICS DEFAULT TO USE
  1154. '              CURRENT.PUI$         PUI TO USE
  1155. '              EXPERT.USER          WHETHER CALL IN EXPERT MODE
  1156. '
  1157. '  OUTPUTS --  Q
  1158. '              B$()
  1159. '              Z$
  1160. '
  1161. '  PURPOSE --  When sysop overrides RBBS-PC's default user
  1162. '              interface (provides a MAIN.PUT), this routine
  1163. '              reads in the table of specifications, presents
  1164. '              the sysop menu, presents the prompt, verifies
  1165. '              that a valid option has been picked, determines
  1166. '              whether the option is another PUI, and passes
  1167. '              back choices to be processed.
  1168. '
  1169.       SUB USERFACE (GDEFAULT$) STATIC
  1170. 59455 IF PREV.PUI$ = CURRENT.PUI$ THEN _
  1171.          GOTO 59458
  1172. 59456 FILE.NAME$ = CURRENT.PUI$
  1173.       CALL GRAPHIC (GDEFAULT$,FILE.NAME$)
  1174.       IF NOT OK THEN _
  1175.          CALL UPDTCALR ("Missing menu " + CURRENT.PUI$,2) : _
  1176.          CURRENT.PUI$ = PREV.PUI$ : _
  1177.          GOTO 59456
  1178.       PREV.PUI$ = CURRENT.PUI$
  1179.       LINE INPUT #2,FILE.NAME$
  1180.       LINE INPUT #2,PRMPT$
  1181.       INPUT #2,VALID.CHOICE$,ACTUAL.COMMANDS$
  1182.       LINE INPUT #2,MENU.CHOICE$
  1183.       LINE INPUT #2,MENU.NAME$
  1184.       LINE INPUT #2,QUIT.COMMAND$
  1185.       LINE INPUT #2,QUIT.PROMPT$
  1186.       LINE INPUT #2,QUIT.SUBCOMMANDS$
  1187.       LINE INPUT #2,QUIT.MENUOPT$
  1188.       LINE INPUT #2,QUIT.MENUS$
  1189.       CALL GRAPHIC (GDEFAULT$,FILE.NAME$)
  1190.       CALL BRKFNAME (FILE.NAME$,MENU.DRVPATH$,X$,Y$,TRUE)
  1191.       MENU.TO.DISPLAY$ = FILE.NAME$
  1192.       J = INSTR(ORIG.COMMANDS$,"?")
  1193.       IF J < 1 THEN _
  1194.          X$ = "" _
  1195.       ELSE X$ = MID$(ALL.OPTS$,J,1)
  1196. 59458 IF EXPERT.USER THEN _
  1197.          GOTO 59461
  1198. 59460 NON.STOP = (PAGE.LENGTH < 1)                                   ' KG060304
  1199.       CALL BUFFILE (MENU.TO.DISPLAY$,X)
  1200. 59461 A$ = PRMPT$
  1201.       TURBO.KEY = -TURBO.KEY.USER
  1202.       SUBROUTINE.PARAMETER = 1
  1203.       CALL TGET
  1204.       IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
  1205.          EXIT SUB
  1206.       IF Q = 0 THEN _
  1207.          GOTO 59458
  1208. 59462 Z$ = B$(1)
  1209.       CALL ALLCAPS (Z$)
  1210.       J = INSTR(VALID.CHOICE$,Z$)
  1211.       IF J < 1 THEN _
  1212.          GOTO 59492
  1213.       Z$ = MID$(ACTUAL.COMMANDS$,J,1)
  1214.       B$(1) = Z$
  1215.       J = INSTR(MENU.CHOICE$,Z$)
  1216.       IF J > 0 THEN _
  1217.          CURRENT.PUI$ = MID$(MENU.NAME$,1 + (J - 1) * 7,7) : _
  1218.          GOTO 59490
  1219.       IF Z$ = X$ THEN _
  1220.          GOTO 59460
  1221.       IF Z$ <> QUIT.COMMAND$ THEN _
  1222.          EXIT SUB
  1223.       IF Q > 1 THEN _
  1224.          Y = 2 : _
  1225.          GOTO 59480
  1226. 59470 A$ = QUIT.PROMPT$
  1227.       TURBO.KEY = -TURBO.KEY.USER
  1228.       CALL TGET
  1229.       IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
  1230.          EXIT SUB
  1231.       IF Q = 0 THEN _
  1232.          GOTO 59458
  1233.       Y = 1
  1234. 59480 Z$ = B$(Y)
  1235.       CALL ALLCAPS (Z$)
  1236.       J = INSTR(QUIT.SUBCOMMANDS$,Z$)
  1237.       IF J < 1 THEN _
  1238.          GOTO 59470
  1239.       J = INSTR(QUIT.MENUOPT$,Z$)
  1240.       IF J > 0 THEN _ 'quit to submenu
  1241.          CURRENT.PUI$ = MID$(QUIT.MENUS$,1 + (J - 1) * 7,7) : _
  1242.          GOTO 59490
  1243.       IF Q = 1 THEN _  'valid but not menu - send to RBBS
  1244.          Q = 2 : _
  1245.          B$(2) = B$(1) : _
  1246.          B$(1) = QUIT.COMMAND$
  1247.       EXIT SUB
  1248. 59490 CALL REMOVE (CURRENT.PUI$," ")
  1249.       CURRENT.PUI$ = MENU.DRVPATH$ + _
  1250.                      CURRENT.PUI$ + _
  1251.                      ".PUI"
  1252.       GOTO 59455
  1253. 59492 CALL QTPUT1 (Z$ + " not valid choice")
  1254.       GOTO 59460
  1255.       END SUB
  1256. 59500 ' $SUBTITLE: 'SUBMENU -- subroutine to process menus'
  1257. ' $PAGE
  1258. '
  1259. '  NAME    -- SUBMENU
  1260. '
  1261. '  INPUTS  --   PARAMETER     MEANING
  1262. '             PASSED.PROMPT$  PROMPT TO DISPLAY
  1263. '             CURRENT.MENU$   NOVICE MENU TO DISPLAY
  1264. '             FRONT.OPT$      DRIVE/PATH/PREFIX OF FILE
  1265. '                             NEEDED FOR TYPED OPTION
  1266. '             BACK.OPT$       SUFFIX/EXTENSION OF FILE
  1267. '                             NEEDED WITH TYPED OPTION
  1268. '             RETURN.ON$      LETTERS CALLING PROGRAM WANTS
  1269. '                               CONTROL ON
  1270. '             GR.DEFAULT$     GRAPHICS DEFAULT TO USE
  1271. '             VERIFY.IN.MENU  WHETHER VERIFY OPTION IS IN MENU
  1272. '             ALL.MENU.OK     WHETHER CONTROL SHOULD RETURN
  1273. '                               WHEN IN MENU
  1274. '             ANS.INDEX       # OF COMMANDS IN TYPE AHEAD
  1275. '             REQUIRE.IN.MENU WHETHER OPTION MUST BE IN MENU
  1276. '
  1277. '  OUTPUTS -- Z$              OPTION PICKED
  1278. '             FILE.NAME$      NAME OF FILE SUPPORTING OPTION
  1279. '
  1280. '
  1281. '  PURPOSE -- Handles menus - including conference, bulletins,
  1282. '             doors, questionnaires.  Supports sub-menus (i.e.
  1283. '             an option on the menu that invokes another menu)
  1284. '
  1285.       SUB SUBMENU (PASSED.PROMPT$,CURRENT.MENU$,FRONT.OPT$, _
  1286.                   BACK.OPT$,RETURN.ON$,GR.DEFAULT$,VERIFY.IN.MENU, _
  1287.                   ALL.MENU.OK,REQUIRE.IN.MENU,BACK.OPT2$) STATIC
  1288. 59510 FILE.NAME$ = CURRENT.MENU$
  1289.       CALL BRKFNAME (CURRENT.MENU$,MNU.DRV$,X$,DF$,TRUE)
  1290.       MENU.FRONT$ = MNU.DRV$ + X$
  1291.       CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$)
  1292.       CURRENT.MENU.VER$ = FILE.NAME$
  1293.       STOP.INTERRUPTS = FALSE
  1294.       IF ANS.INDEX > 1 THEN _
  1295.          Q = 1 : _
  1296.          GOTO 59530
  1297.       IF EXPERT.USER THEN _
  1298.          GOTO 59520
  1299. 59515 CALL BUFFILE (CURRENT.MENU.VER$,ANS.INDEX) 'show menu
  1300. 59520 A$ = PASSED.PROMPT$            'get response
  1301.       SUBROUTINE.PARAMETER = 1
  1302.       CALL TGET
  1303.       IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _
  1304.          EXIT SUB
  1305.       ANS.INDEX = 1
  1306.       LAST.INDEX = Q
  1307. 59530 Z$ = B$(ANS.INDEX)
  1308.       CALL ALLCAPS (Z$)
  1309.       IF INSTR(RETURN.ON$,Z$) THEN _  'check whether calling pgm wants
  1310.          EXIT SUB
  1311.       IF INSTR("LH?",Z$) THEN _       'check whether caller wants help
  1312.          GOTO 59515
  1313.       IF INSTR(Z$,".") > 0 THEN _
  1314.          GOTO 59532
  1315.       FPRE$ = FRONT.OPT$
  1316.       GOSUB 59538
  1317.       IF (BF < 2) AND (NOT OK) THEN _
  1318.          FPRE$ = MNU.DRV$ : _                                        ' KG061102
  1319.          GOSUB 59538 : _                                             ' KG061102
  1320.          IF NOT OK THEN _    ' support shared options                ' KG061102
  1321.             FPRE$ = MENU.FRONT$ : _                                  ' KG061102
  1322.             GOSUB 59538                                              ' KG061102
  1323.       IF NEW.MENU THEN _
  1324.          NEW.MENU = FALSE : _
  1325.          GOTO 59515
  1326.       IF OK THEN _
  1327.          EXIT SUB
  1328. 59532 IF INSTR(RETURN.ON$,LEFT$(Z$,1)) > 0 THEN _
  1329.          EXIT SUB
  1330.       GOSUB 59547
  1331.       GOTO 59515
  1332. 59538 FILNAME$ = FPRE$ + Z$
  1333.       CALL BADFILE (FILNAME$,BF)
  1334.       IF BF > 1 THEN _
  1335.          OK = FALSE : _
  1336.          RETURN
  1337.       FILE.NAME$ = FILNAME$ + _
  1338.                    BACK.OPT$
  1339.       CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$)
  1340.       IF NOT OK THEN _
  1341.          IF BACK.OPT2$ <> "" THEN _
  1342.             FILE.NAME$ = FILNAME$ + _
  1343.                          BACK.OPT2$ : _
  1344.             CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$)
  1345.       IF OK THEN _
  1346.          IF SYSOP OR (NOT REQUIRE.IN.MENU) THEN _
  1347.             RETURN _
  1348.          ELSE CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND) : _
  1349.               IF FOUND THEN _
  1350.                  RETURN _
  1351.               ELSE GOTO 59540
  1352.       IF (NOT VERIFY.IN.MENU) THEN _
  1353.          GOTO 59540
  1354.       CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND)  'verify against menu itself
  1355.       IF FOUND THEN _
  1356.          IF ALL.MENU.OK THEN _
  1357.             RETURN
  1358. 59540 X$ = FPRE$ + _
  1359.            Z$ + _
  1360.            ".MNU" 'check whether option is a menu
  1361.       FILE.NAME$ = X$
  1362.       CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$)
  1363.       IF OK THEN _
  1364.          NEW.MENU = TRUE : _
  1365.          CURRENT.MENU.VER$ = FILE.NAME$ : _
  1366.          CURRENT.MENU$ = X$ : _
  1367.          CALL BRKFNAME (CURRENT.MENU$,MNU.DRV$,X$,DF$,TRUE) : _
  1368.          MENU.FRONT$ = MNU.DRV$ + X$ : _
  1369.          RETURN
  1370.       IF VERIFY.IN.MENU AND FOUND AND NOT REQUIRE.IN.MENU THEN _
  1371.          CALL UPDTCALR("Option " + Z$ + " on menu " + _
  1372.                        CURRENT.MENU$ + " but not found",1)
  1373.       RETURN
  1374. 59547 CALL QTPUT1 ("No such option " + Z$)
  1375.       RETURN
  1376. 59548 END SUB
  1377. 59600 ' $SUBTITLE: 'SETECHO -- subroutine to reset who echoes'
  1378. ' $PAGE
  1379. '
  1380. '  NAME    -- SETECHO
  1381. '
  1382. '  INPUTS  --   PARAMETER     MEANING
  1383. '               NEW.ECHO$   The new echo option
  1384. '               LOCAL.USER
  1385. '
  1386. '  OUTPUTS -- REMOTE.ECHO   Whether RBBS is to echo what a
  1387. '                           remote caller types
  1388. '
  1389. '  PURPOSE -- Resets who echos.  "R" is for RBBS to echo.
  1390. '             "I" is for intermediate host to echo.
  1391. '             "C" is for caller's communication pgm to echo.
  1392. '
  1393.       SUB SETECHO (NEW.ECHO$) STATIC
  1394.       IF NEW.ECHO$ = PREV.ECHO$ THEN _
  1395.          EXIT SUB
  1396.       IF NEW.ECHO$ = "R" THEN _
  1397.          REMOTE.ECHO = (NOT LOCAL.USER) _
  1398.       ELSE REMOTE.ECHO = FALSE
  1399.       IF LOCAL.USER THEN _
  1400.          GOTO 59602
  1401.       IF NEW.ECHO$ = "I" THEN _
  1402.           IF FOSSIL THEN _
  1403.              BYTES% = LEN(HOST.ECHO.ON$) : _
  1404.              CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.ON$) : _
  1405.              GOTO 59602 _
  1406.           ELSE PRINT #3,HOST.ECHO.ON$; : _
  1407.                GOTO 59602
  1408.       IF PREV.ECHO$ = "I" THEN _
  1409.           IF FOSSIL THEN _
  1410.              BYTES% = LEN(HOST.ECHO.OFF$) : _
  1411.              CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.OFF$) _
  1412.           ELSE PRINT #3,HOST.ECHO.OFF$;
  1413. 59602 PREV.ECHO$ = NEW.ECHO$
  1414.       END SUB
  1415. 59698 ' $SUBTITLE: 'MIMPORT -- subroutine to import a message'
  1416. ' $PAGE
  1417. '
  1418. '  NAME    -- MIMPORT
  1419. '
  1420. '  INPUTS  --   PARAMETER     MEANING
  1421. '               MAX.LINES     MAXIMUM # OF LINES
  1422. '               MAX.LEN       MAXIMUM LENGTH OF A LINE
  1423. '               NUM.LINES     NUMBER OF LINES ALREADY IN MESSAGE
  1424. '               LINE.ARA$     ARRAY OF LINES IN MESSAGE
  1425. '
  1426. '  OUTPUTS --   NUM.LINES
  1427. '               LINE.ARA$
  1428. '
  1429. '  PURPOSE -- Allows local user to append a text file to
  1430. '             a message.   Will word wrap if needed.
  1431. '
  1432.       SUB MIMPORT (MAX.LINES,MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC
  1433.       IF NOT (LOCAL.USER OR SYSOP) THEN _
  1434.          CALL QTPUT1 ("Only for SYSOPS/local users") : _
  1435.          EXIT SUB
  1436. 59700 SUBROUTINE.PARAMETER = 1
  1437.       A$ = "Import what file" + PRESS.ENTER$
  1438.       CALL TGET
  1439.       IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _
  1440.          EXIT SUB
  1441.       CALL FINDIT (B$)
  1442.       IF NOT OK THEN _
  1443.          CALL QTPUT1 (B$ + " not found") : _
  1444.          GOTO 59700
  1445.       WHILE NOT EOF(2) AND NUM.LINES < MAX.LINES
  1446.          NUM.LINES = NUM.LINES + 1
  1447.          LINE INPUT #2,LINE.ARA$(NUM.LINES)
  1448.       WEND
  1449.       CLOSE 2
  1450.       CALL WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$())
  1451.       END SUB
  1452. 59703 ' $SUBTITLE: 'WORDWRAP -- subroutine to wrap lines in a message'
  1453. ' $PAGE
  1454. '
  1455. '  NAME    -- WORDWRAP
  1456. '
  1457. '  INPUTS  --   PARAMETER     MEANING
  1458. '               MAX.LEN       MAXIMUM LENGTH OF A SINGLE LINE
  1459. '               NUM.LINES     NUMBER OF LINES IN A MESSAGE
  1460. '               LINE.ARA$     ALL THE LINES IN THE MESSAGE
  1461. '
  1462. '  OUTPUTS --   NUM.LINES
  1463. '               LINE.ARA$
  1464. '
  1465. '  PURPOSE -- Batch adjusts a message, wrapping lines if
  1466. '             needed.  Preserves paragraph structure.
  1467. '
  1468.       SUB WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC
  1469.       J = 1
  1470.       WHILE J <= NUM.LINES
  1471. 59704    CALL TRIMTRAIL (LINE.ARA$(J)," ")
  1472.          K = LEN(LINE.ARA$(J))
  1473.          IF K <= MAX.LEN THEN _
  1474.             GOTO 59705
  1475.          CALL FINDLAST (LINE.ARA$(J)," ",LAST.POS,HOW.MANY)
  1476.          CALL ANYBUT (LINE.ARA$(J),1,">",X)                          ' KG061202
  1477.          CALL ANYBUT (LINE.ARA$(J+1),1,">",TEMP)                     ' KG061202
  1478.          IF LEFT$(LINE.ARA$(J + 1),2) = "  " OR ((TEMP > 0) AND X <> TEMP) THEN _ ' KG061202
  1479.             FOR K = NUM.LINES TO J + 1 STEP -1 : _
  1480.                LINE.ARA$(K + 1) = LINE.ARA$(K) : _
  1481.             NEXT : _
  1482.             NUM.LINES = NUM.LINES + 1 : _
  1483.             LINE.ARA$(J + 1) = ""
  1484.          IF X > 1 THEN _                                             ' KG061202
  1485.             IF MID$(LINE.ARA$(J),X,1) = " " THEN _                   ' KG061202
  1486.                X = X + 1                                             ' KG061202
  1487.          X$ = LEFT$(LINE.ARA$(J),X-1)                                ' KG061202
  1488.          IF LAST.POS < 1 THEN _
  1489.             LINE.ARA$(J + 1) = X$ + MID$(LINE.ARA$(J),MAX.LEN) + MID$(LINE.ARA$(J + 1),X) : _ ' KG061202
  1490.             LINE.ARA$(J) = LEFT$(LINE.ARA$(J),MAX.LEN - 1) + "-" _
  1491.          ELSE B$ = LEFT$(" ", - (LEN(LINE.ARA$(J + 1)) > 0)) : _
  1492.               LINE.ARA$(J + 1) = X$ + MID$(LINE.ARA$(J),LAST.POS + 1) + B$ + MID$(LINE.ARA$(J + 1),X) : _ ' KG061202
  1493.               LINE.ARA$(J) = LEFT$(LINE.ARA$(J),LAST.POS - 1)
  1494.          GOTO 59704
  1495. 59705    J = J + 1
  1496.       WEND
  1497.       NUM.LINES = NUM.LINES - (LEN(LINE.ARA$(NUM.LINES + 1)) > 0)
  1498.       END SUB
  1499. 59750 ' $SUBTITLE: 'SETABORT -- subroutine to set a time-limit'
  1500. ' $PAGE
  1501. '
  1502. '  NAME    -- SETABORT
  1503. '
  1504. '  INPUTS  --   PARAMETER     MEANING
  1505. '             SECONDS.TO.ADD  # SECONDS AFTER CURRENT TIME
  1506. '                             WHEN TIME LIMIT IS TO EXPIRE
  1507. '
  1508. '  OUTPUTS --  ABORT.TIME!    THE TIME (IN SECONDS AFTER MIDNIGHT)
  1509. '                             WHEN TIME LIMIT EXPIRES
  1510. '
  1511. '  PURPOSE -- Sets a time limit in units of seconds after
  1512. '             midnight after which a time limit will expire.
  1513. '             Calling program passes number of seconds that can
  1514. '             elapse before time-limit is reached.
  1515. '
  1516.       SUB SETABORT (ABORT.TIME!,SECONDS.TO.ADD) STATIC
  1517.       CALL FINDTIME (ABORT.TIME!)
  1518.       ABORT.TIME! = ABORT.TIME! + SECONDS.TO.ADD
  1519.       END SUB
  1520. 59760 ' $SUBTITLE: 'ANYBUT -- subroutine to find where a word begins'
  1521. ' $PAGE
  1522. '
  1523. '  NAME    -- ANYBUT
  1524. '
  1525. '  INPUTS  --   PARAMETER     MEANING
  1526. '               STRNG$        STRING TO SEARCH FOR WORDS
  1527. '               BEG%          BYTE POSITION IN STRNG$ TO
  1528. '                                BEGIN SEARCHING
  1529. '               SKIP.CHARS$   CHARACTERS TO SKIP OVER WHEN
  1530. '                                SEARCHING
  1531. '
  1532. '  OUTPUTS --   WHEREIS%      BYTES POSITION IN STRNG$ WHERE
  1533. '                             WORD BEGINS
  1534. '
  1535. '  PURPOSE -- Parser.   Finds where a "word" begins, where
  1536. '             any character will be accepted as the beginning of a
  1537. '             word except those listed in SKIP.CHAR$
  1538. '
  1539.       SUB ANYBUT (STRNG$, BEG%, SKIP.CHARS$, WHEREIS%) STATIC
  1540.       X$ = STRNG$ + _
  1541.            CHR$(0)
  1542.       WHEREIS% = BEG%
  1543.       IF WHEREIS% < 1 THEN _
  1544.          WHEREIS% = 1
  1545.       WHILE INSTR(SKIP.CHARS$, MID$(X$, WHEREIS%, 1)) > 0
  1546.          WHEREIS% = WHEREIS% + 1
  1547.       WEND
  1548.       IF WHEREIS% > LEN(STRNG$) THEN _
  1549.          WHEREIS% = 0
  1550.       END SUB
  1551. 59770 ' $SUBTITLE: 'FINDEND -- subroutine to find where a word ends'
  1552. ' $PAGE
  1553. '
  1554. '  NAME    -- FINDEND
  1555. '
  1556. '  INPUTS  --   PARAMETER     MEANING
  1557. '               STRNG$        STRING TO SEARCH FOR WORDS
  1558. '               BEG%          POSITION IN STRNG$ TO BEGIN SEARCH
  1559. '               STOP.WITH$    CHARACTERS THAT TERMINATE A WORD
  1560. '
  1561. '  OUTPUTS      WHEREIS%      POSITION IN STRNG$ WHERE WORD ENDS
  1562. '                             (I.E. THE LAST CHARACTER OF THE WORD)
  1563. '
  1564. '  PURPOSE -- Parser.   Finds where a "word" ends, where
  1565. '             any character will be counted as in a word
  1566. '             except for those in STOP.WITH$ or when the end of
  1567. '             the string is found.
  1568. '
  1569.       SUB FINDEND (STRNG$, BEG%, STOP.WITH$, WHEREIS%) STATIC
  1570.       B = BEG%
  1571.       IF B < 1 THEN _
  1572.          B = 1
  1573.       IF B > LEN(STRNG$) THEN _
  1574.          X$ = STOP.WITH$ _
  1575.       ELSE X$ = MID$(STRNG$, B) + _
  1576.                 STOP.WITH$
  1577.       I = 1
  1578.       X = INSTR(STOP.WITH$, MID$(X$, I, 1))
  1579.       WHILE X = 0
  1580.          I = I + 1
  1581.          X = INSTR(STOP.WITH$, MID$(X$, I, 1))
  1582.       WEND
  1583.       WHEREIS% = I - 1 + B - 1
  1584.       END SUB
  1585. 59780 ' $SUBTITLE: 'GETALL -- subroutine to create directory list'
  1586. ' $PAGE
  1587. '
  1588. '  NAME    -- GETALL
  1589. '
  1590. '  INPUTS  --   PARAMETER     MEANING
  1591. '               LOOK.IN$      NAME OF FILE TO SEARCH
  1592. '               DIR.EXT$      MAIN DIRECTORY EXTENSION TO USE
  1593. '               START.POS     LAST POSITION USED IN ARRAY
  1594. '
  1595. '  OUTPUTS      START.POS     LAST ELEMENT USED IN ARRAY
  1596. '               LOAD.INTO$    ARRAY TO LOAD ELEMENTS FOUND
  1597. '
  1598. '  PURPOSE -- Creates a list (LOAD.INTO$) of all directories
  1599. '             found in directory of directories (LOOK.IN$).
  1600. '             Used for determining what gets listed when doing
  1601. '             an "ALL" to determinate what separate directories
  1602. '             to display.  Directory name must be all caps
  1603. '             and followed by a space or dash.
  1604. '
  1605.       SUB GETALL (LOOK.IN$, LOAD.INTO$(1), DIR.EXT$, START.POS) STATIC
  1606.       IF MASTER.DIRECTORY.NAME$ <> "" THEN _
  1607.          START.POS = START.POS + 1 : _
  1608.          LOAD.INTO$(START.POS) = MASTER.DIRECTORY.NAME$ : _
  1609.          EXIT SUB
  1610.       CALL FINDIT(LOOK.IN$)
  1611.       IF NOT OK THEN _
  1612.          EXIT SUB
  1613.       MAX.LOAD = UBOUND(LOAD.INTO$, 1)
  1614.       START.SORT = START.POS + 1
  1615.       WHILE NOT EOF(2) AND START.POS < MAX.LOAD
  1616.          LINE INPUT #2, A$
  1617.          LAST.POS = LEN(A$)
  1618.          CALL ANYBUT(A$, 1, " ", X)
  1619.          WHILE X > 0 AND X < LAST.POS AND START.POS < MAX.LOAD
  1620.             CALL FINDEND(A$, X + 1, " -.", Y)
  1621.             L = Y - X + 1
  1622.             IF L > 8 THEN _
  1623.                GOTO 59782
  1624.             B$ = MID$(A$, X, L)
  1625.             IF B$ = "ALL" THEN _
  1626.                GOTO 59782
  1627.             CALL BADFILECHAR (B$,I)
  1628.             IF NOT I THEN _
  1629.                GOTO 59782
  1630.             Z$ = LEFT$(B$,1)
  1631.             IF (Z$ >= "0" AND Z$ <= "9") OR _
  1632.                (Z$ >= "A" AND Z$ <= "Z") THEN _
  1633.                   Z$ = B$ : _
  1634.                   CALL ALLCAPS (Z$) : _
  1635.                   IF Z$ = B$ THEN _
  1636.                      LOAD.INTO$(START.POS + 1) = Z$ : _
  1637.                      IF USE.DIR.ORDER THEN _
  1638.                         I = START.SORT : _
  1639.                         WHILE LOAD.INTO$(I) <> Z$ : _
  1640.                            I = I + 1 : _
  1641.                         WEND : _
  1642.                         START.POS = START.POS - (I > START.POS) _
  1643.                      ELSE _
  1644.                         I = START.SORT : _
  1645.                         Z = VAL(Z$) : _
  1646.                         WHILE VAL(LOAD.INTO$(I)) < Z : _
  1647.                            I = I + 1 : _
  1648.                         WEND : _
  1649.                         WHILE VAL(LOAD.INTO$(I)) = Z AND LOAD.INTO$(I) < Z$ AND I <= START.POS : _
  1650.                            I = I + 1 : _
  1651.                         WEND : _
  1652.                         IF I > START.POS THEN _
  1653.                            START.POS = I _
  1654.                         ELSE IF Z$ <> LOAD.INTO$(I) THEN _
  1655.                                 FOR J = START.POS TO I STEP -1 : _
  1656.                                    LOAD.INTO$(J + 1) = LOAD.INTO$(J) : _
  1657.                                 NEXT : _
  1658.                                 LOAD.INTO$(I) = Z$ : _
  1659.                                 START.POS = START.POS + 1
  1660. 59782       CALL ANYBUT(A$, Y + 1, " ", X)
  1661.          WEND
  1662.       WEND
  1663.       CLOSE 2
  1664.       END SUB
  1665. 59790 ' $SUBTITLE: 'FINDFILE -- subroutine to find a file'
  1666. ' $PAGE
  1667. '
  1668. '  NAME    --  FINDFILE
  1669. '
  1670. '  INPUTS  --  PARAMETER         MENANING
  1671. '               FILNAME$         NAME OF FILE TO LOOK FOR
  1672. '               FEXISTS          WHETHER FILE EXISTS
  1673. '
  1674. '  OUTPUTS --  RETURNED.VALUE    VALUE RETURNED
  1675. '                                TRUE  = FILE EXISTS
  1676. '                                FALSE = FILE DOES NOT EXIST
  1677. '
  1678. '  PURPOSE --  Determine whether passed file FILNAME$ exists
  1679. '              Unlike, FINDIT, this routine does not open any
  1680. '              file and, hence, does not create one in determining
  1681. '              whether a file exists.
  1682. '
  1683.       SUB FINDFILE (FILNAME$,FEXISTS) STATIC
  1684.       CALL BADFILECHAR (FILNAME$,FEXISTS)
  1685.       IF FEXISTS THEN _
  1686.          CALL RBBSFIND (FILNAME$,Z,Y,M,D) : _
  1687.          FEXISTS = (Z = 0)
  1688.       END SUB
  1689. 59800 ' $SUBTITLE: 'BADFILECHAR -- checks file for illegal char'
  1690. ' $PAGE
  1691. '
  1692. '  NAME    --  BADFILECHAR
  1693. '
  1694. '  INPUTS  --  PARAMETER         MEANING
  1695. '               FILNAME$         NAME OF FILE TO CHECK
  1696. '
  1697. '  OUTPUTS --  IS.OK            WHETHER NAME OK
  1698. '
  1699. '  PURPOSE --  Part of test for file's existence.  If bad
  1700. '              character in name, can't exist.
  1701. '
  1702.       SUB BADFILECHAR (FILNAME$,IS.OK) STATIC
  1703.       L = LEN(FILNAME$)
  1704.       IF L > 2 THEN _
  1705.          IF INSTR(3,FILNAME$,":") > 0 THEN _
  1706.             IS.OK = FALSE : _
  1707.             EXIT SUB
  1708.       X$ = FILNAME$ + "="
  1709.       I = 1
  1710.       WHILE INSTR("/[]|<>+=;, ?*",MID$(X$,I,1)) = 0 AND ASC(MID$(X$,I)) < 128
  1711.          I = I + 1
  1712.       WEND
  1713.       IS.OK = I > L
  1714.       END SUB
  1715. '
  1716. 59850 ' $SUBTITLE: 'CONFMAIL -- quickly checks mail waiting'
  1717. ' $PAGE
  1718. '
  1719. '  NAME    -- CONFMAIL
  1720. '
  1721. '  INPUTS  -- PARAMETER        MEANING
  1722. '         SKIP.CONFIRM         Whether to skip confirm of option
  1723. '         CONFMAIL.LIST$       File of user/message pairs to check
  1724. '         ACTIVE.USER.FILE$    Active user file (restored on exit)
  1725. '         ACTIVE.MESSAGE.FILE$ Active msg file (restored)
  1726. '  OUTPUTS -- None
  1727. '
  1728. '  PURPOSE -- Quicking scans message header record to get
  1729. '             last msg # and user record to get whether any
  1730. '             new mail and last msg read, reports both, using
  1731. '             highlighting if new mail to caller.
  1732. '
  1733.       SUB CONFMAIL (MAILCHECK.CONFIRM) STATIC
  1734.       SKIP.JOIN.UNJOIN = NON.STOP                                    ' KG071906
  1735.       IF START.HASH = 1 AND USER.FILE.INDEX > 0 THEN _
  1736.          CALL FINDIT (CONFMAIL.LIST$) _
  1737.       ELSE OK = FALSE
  1738.       IF NOT OK THEN _
  1739.          EXIT SUB
  1740.       IF MAILCHECK.CONFIRM THEN _
  1741.          A$ = "Check conferences for mail ([Y],N)" : _
  1742.          SUBROUTINE.PARAMETER = 1 : _
  1743.          TURBO.KEY = -TURBO.KEY.USER : _
  1744.          CALL TGET : _
  1745.          IF NO OR SUBROUTINE.PARAMETER < 0 THEN _
  1746.             EXIT SUB
  1747.       CALL SKIPLINE (1)
  1748.       CALL QTPUT1 ("Checking Message Bases since last on...")
  1749.       ANY.MAIL = FALSE
  1750.       STOP.INTERRUPTS = FALSE
  1751.       A1$ = ACTIVE.USER.FILE$
  1752.       M$ = ACTIVE.MESSAGE.FILE$
  1753.       TEMP.INDIV.VALUE$ = ""
  1754.       SUIX = USER.FILE.INDEX
  1755.       USER.RECORD.HOLD$ = USER.RECORD$
  1756.       OK = TRUE
  1757. 59852 IF EOF(2) OR NOT OK THEN _
  1758.          GOTO 59854
  1759.          CALL READANY
  1760.          ACTIVE.USER.FILE$ = A$
  1761.          CALL READANY
  1762.          IF EC > 0 THEN _
  1763.             GOTO 59854
  1764.          ACTIVE.MESSAGE.FILE$ = A$
  1765.          CALL FINDFILE (ACTIVE.USER.FILE$,OK)
  1766.          IF NOT OK THEN _
  1767.             GOTO 59854
  1768.          CALL OPENUSER (HIGHEST.USER.RECORD)
  1769.          FIELD 5, 128 AS USER.RECORD$
  1770.          CALL FINDFILE (ACTIVE.MESSAGE.FILE$,OK)
  1771.          IF NOT OK THEN _
  1772.             GOTO 59854
  1773.          CALL FINDUSER (ORIG.USER.NAME$,"",START.HASH,LEN.HASH,_
  1774.                         0,0,HIGHEST.USER.RECORD,_
  1775.                         FOUND,UFI,SL)
  1776.          IF NOT FOUND THEN _
  1777.             GOTO 59852
  1778.          CALL OPENMSG
  1779.          FIELD 1, 128 AS MESSAGE.RECORD$
  1780.          GET 1,1
  1781.          ANY.MAIL = TRUE
  1782.          X = CVI(MID$(USER.RECORD$,57,2))
  1783.          X = (X AND 512) > 0
  1784.          CALL BRKFNAME (ACTIVE.USER.FILE$,X$,Y$,Z$,FALSE)
  1785.          A = CVI(MID$(USER.RECORD$,51,2))
  1786.          B = VAL(LEFT$(MESSAGE.RECORD$,8))
  1787.          Z = (B - A)
  1788.          IF Z < 0 THEN _                                             ' KG051701
  1789.             A = 0 : _                                                ' KG051701
  1790.             Z = B _                                                  ' KG051701
  1791.          ELSE IF Z = 0 THEN _                                        ' KG051701
  1792.                  X = FALSE                                           ' KG051701
  1793.          A$ = MID$(STR$((B > A) * Z),2)
  1794.          SL = LEN(A$)
  1795.          A$ = SPACE$(-(SL<3) * (3-SL)) + A$
  1796.          SL = LEN(Y$)
  1797.          CONF$ = LEFT$(Y$,SL-1)
  1798.          Y$ = CONF$ + SPACE$(-(SL<8) * (8-SL))
  1799.          IF X THEN _
  1800.             X$ = EMPHASIZE.ON$ : _
  1801.             Z$ = EMPHASIZE.OFF$ _
  1802.          ELSE X$ = "" : _
  1803.               Z$ = ""
  1804.          A$ = Y$ + ": " + A$ + " new message(s): " + _
  1805.               X$ + MID$(" None *Some*",-6 * X + 1,6) + " to you" + Z$
  1806.          SUBROUTINE.PARAMETER = 5
  1807.          CALL TPUT
  1808.          IF SKIP.JOIN.UNJOIN THEN _                                  ' KG071907
  1809.             CALL ASKMORE ("",TRUE,TRUE,X,TRUE) : _
  1810.             GOTO 59853
  1811.          TURBO.KEY = -TURBO.KEY.USER
  1812.          CALL ASKMORE (",J)oin,U)njoin",TRUE,FALSE,X,FALSE)
  1813.          IF NO THEN _
  1814.             GOTO 59854
  1815.          X$ = LEFT$(B$(1),1)
  1816.          CALL ALLCAPS (X$)
  1817.          IF X$ = "U" THEN _
  1818.             LSET USER.RECORD$ = CHR$(0) + "deleted user" : _
  1819.             USER.FILE.INDEX = UFI : _
  1820.             SUBROUTINE.PARAMETER = 6 : _
  1821.             CALL FILELOCK : _
  1822.             PUT 5, UFI : _
  1823.             SUBROUTINE.PARAMETER = 8 : _
  1824.             CALL FILELOCK : _
  1825.             CALL QTPUT1 ("Omitted you from " + CONF$) _
  1826.          ELSE IF X$ = "J" THEN _
  1827.                  HOME.CONFERENCE$ = CONF$ : _
  1828.                  GOTO 59854
  1829. 59853 IF NOT RET THEN _
  1830.          GOTO 59852
  1831. 59854 ACTIVE.USER.FILE$ = A1$
  1832.       CALL OPENUSER (HIGHEST.USER.RECORD)
  1833.       FIELD 5, 128 AS USER.RECORD$
  1834.       IF (NOT RET) AND NOT ANY.MAIL THEN _
  1835.          CALL QTPUT1 ("No new personal mail")
  1836.       USER.FILE.INDEX = SUIX
  1837.       LSET USER.RECORD$ = USER.RECORD.HOLD$
  1838.       ACTIVE.MESSAGE.FILE$ = M$
  1839.       CALL OPENMSG
  1840.       FIELD 1, 128 AS MESSAGE.RECORD$
  1841.       GET 1,1
  1842.       NON.STOP = (PAGE.LENGTH > 0)
  1843.       END SUB
  1844. 59858 ' $SUBTITLE: 'ASKMORE -- pauses when possible screen full'
  1845. ' $PAGE
  1846. '
  1847. '  NAME    -- ASKMORE
  1848. '
  1849. '  INPUTS  --   PARAMETER     MEANING
  1850. '               EXTRA.PRMPT$  STRING TO ADD TO MORE PROMPT AT END
  1851. '               OVERWRITE     WHETHER TO WIPE AWAY PROMPT
  1852. '
  1853. '  OUTPUTS --   B$()
  1854. '               NO
  1855. '
  1856. '  PURPOSE -- Determines whether need to pause if screen full.
  1857. '             And, if so, asks the appropriate question.  If non-
  1858. '             stop, at least check for carrier present.
  1859. '
  1860.       SUB ASKMORE (EXTRA.PRMPT$, OVERWRITE, CHECK.LINES,ABORT.INDEX,CANT.INTERRUPT) STATIC
  1861.       NO = FALSE
  1862.       IF CHECK.LINES THEN _
  1863.          X = -DISPLAY.AS.UNIT*UNIT.COUNT -(NOT DISPLAY.AS.UNIT)*LINES.PRINTED : _
  1864.          IF X < PAGE.LENGTH OR (PAGE.LENGTH = 0) THEN _
  1865.             Q = 0 : _
  1866.             EXIT SUB
  1867.       IF ONE.STOP THEN _
  1868.          ONE.STOP = FALSE : _
  1869.          NON.STOP = TRUE : _
  1870.          GOTO 59860
  1871.       IF NON.STOP THEN _
  1872.          LINES.PRINTED = 0 : _
  1873.          CALL CHKCARRIER : _                                         ' KG061203
  1874.          IF KEYBOARD.STACK$ = "" AND COMMPORT.STACK$ = "" THEN _
  1875.             EXIT SUB _
  1876.          ELSE NON.STOP = FALSE
  1877. 59860 CALL QTPUT (EMPHASIZE.OFF$,0)
  1878.       IF CANT.INTERRUPT THEN _
  1879.          TURBO.KEY = 2 : _
  1880.          A$ = "Press Any Key to continue" _
  1881.       ELSE A$ = MORE.PROMPT$ + EXTRA.PRMPT$ + LEFT$(">",-EXPERT.USER)
  1882.       X = LEN(A$) + 2
  1883.       NO.ADVANCE = OVERWRITE
  1884.       SUBROUTINE.PARAMETER = 1
  1885.       IF EXTRA.PRMPT$ = "" AND TURBO.KEY = 0 THEN _
  1886.          TURBO.KEY = -TURBO.KEY.USER
  1887.       MACRO.MIN = 2
  1888.       CALL TGET
  1889.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1890.         EXIT SUB
  1891.       TURBO.KEY = FALSE
  1892.       DF$ = B$                                                       ' KG072701
  1893.       CALL ALLCAPS (DF$)                                             ' KG072701
  1894.       I = INSTR(";C;A;",";"+DF$+";")                                 ' KG072701
  1895.       IF I = 1 THEN _                                                ' KG072701
  1896.          NON.STOP = TRUE : _                                         ' KG072701
  1897.          Q = 0                                                       ' KG072701
  1898.       CALL WIPELINE (X + LEN(B$))
  1899.       IF NOT HIGHLIGHT.OFF THEN _                                    ' MZ061401
  1900.          CALL QTPUT (LAST.SMART.COLOR$,0)                            ' MZ061401
  1901.       IF CANT.INTERRUPT THEN _
  1902.          NO = FALSE : _
  1903.          EXIT SUB
  1904.       IF I = 3 THEN _                                                ' KG072701
  1905.          ABORT.INDEX = 32000
  1906.       IF NO THEN _
  1907.          KEYBOARD.STACK$ = "" : _
  1908.          COMMPORT.STACK$ = "" : _                                    ' MZ060302
  1909.          LAST.SMART.COLOR$ = ""                                      ' MZ060302
  1910.       END SUB
  1911. 59880 ' $SUBTITLE: 'COMPDATE -- subroutine to compute elased days'
  1912. ' $PAGE
  1913. '
  1914. '  NAME    -- COMPDATE
  1915. '
  1916. '  INPUTS  --   PARAMETER     MEANING
  1917. '                   YY        YEAR
  1918. '                   MM        MONTH
  1919. '                   DD        DAY
  1920. '                 RESULT!    LOCATION TO PLACE THE RESULT
  1921. '
  1922. '  OUTPUTS -- RESULT!        COMPUTE COMPUTATIONAL DATE
  1923. '
  1924. '  PURPOSE -- Computes a computational date from YEAR, MONTH, DAY.
  1925. '             Results may be used to compute the number of elapsed
  1926. '             days between two dates.  You may pass a 2 or 4 digit
  1927. '             year, but for meaningful results, be consistent
  1928. '
  1929.       SUB COMPDATE (YY,MM,DD,RESULT!) STATIC
  1930.       IF MM < 1 OR MM > 12 THEN _
  1931.          MM = 1
  1932.       RESULT! = YY * 365.0 + _
  1933.                 INT((YY - 1) / 4) + _
  1934.                 (MM - 1) * 28 + _
  1935.                 VAL(MID$("000303060811131619212426",(MM - 1) * 2 + 1,2)) - _
  1936.                 ((MM > 2) AND ((YY MOD 4) = 0)) + _
  1937.                 DD
  1938.       END SUB
  1939. 59890 ' $SUBTITLE: 'EXPDATE -- subroutine to display expiration date'
  1940. ' $PAGE
  1941. '
  1942. '  NAME    -- EXPDATE
  1943. '
  1944. '  INPUTS  --   PARAMETER           MEANING
  1945. '             REGISTRATION.DATE!    COMPUTATIONAL REGISTRATION DATE
  1946. '             REGISTRATION.PERIOD   DAYS IN REGISTRATION PERIOD
  1947. '
  1948. '  OUTPUTS -- EXP.DATE$             DISPLAYABLE EXPIRATION DATE
  1949. '
  1950. '  PURPOSE -- Computes/creates a displayable registration
  1951. '             expiration date using registration date and days in
  1952. '             registration period.
  1953. '
  1954.       SUB EXPDATE (REGISTRATION.DATE!,REGISTRATION.PERIOD,EXP.DATE$) STATIC
  1955.       EXPIRE.DATE! = REGISTRATION.DATE! + REGISTRATION.PERIOD
  1956.       EXPIRE.YEAR! = INT((EXPIRE.DATE! - EXPIRE.DATE! / 1461) / 365)
  1957.       EXPIRE.DAY% = EXPIRE.DATE! - (EXPIRE.YEAR! * 365 + INT((EXPIRE.YEAR! -1)/4))
  1958.       EXPIRE.MONTH% = -((EXPIRE.YEAR! MOD 4)<>0) * _
  1959.                       (1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 59) - _
  1960.                       (EXPIRE.DAY% > 90) - (EXPIRE.DAY% >120) - _
  1961.                       (EXPIRE.DAY% > 151) - (EXPIRE.DAY% > 181) - _
  1962.                       (EXPIRE.DAY% > 212) - (EXPIRE.DAY% > 243) - _
  1963.                       (EXPIRE.DAY% > 273) - (EXPIRE.DAY% > 304) - _
  1964.                       (EXPIRE.DAY% > 334)) - ((EXPIRE.YEAR! MOD 4) = 0) * _
  1965.                       (1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 60) - _
  1966.                       (EXPIRE.DAY% > 91) - (EXPIRE.DAY% >121) - _
  1967.                       (EXPIRE.DAY% > 152) - (EXPIRE.DAY% > 182) - _
  1968.                       (EXPIRE.DAY% > 213) - (EXPIRE.DAY% > 243) - _
  1969.                       (EXPIRE.DAY% > 274) - (EXPIRE.DAY% > 305) - _
  1970.                       (EXPIRE.DAY% > 335))
  1971.       EXPIRE.DAY% = (EXPIRE.DAY% - ((EXPIRE.MONTH% - 1) * 28 + _
  1972.          VAL(MID$("000303060811131619212426",(EXPIRE.MONTH% -1) * 2 + 1,2)))) + _
  1973.          ((EXPIRE.MONTH% > 2) AND ((EXPIRE.YEAR! MOD 4) = 0))
  1974.       EXP.DATE$ = RIGHT$("0" + MID$(STR$(EXPIRE.MONTH%),2),2) + _
  1975.                   "/" + _
  1976.                   RIGHT$("0" + MID$(STR$(EXPIRE.DAY%),2),2) + _
  1977.                   "/" + _
  1978.                   RIGHT$(STR$(EXPIRE.YEAR!),2)
  1979.       END SUB
  1980. 59920 ' $SUBTITLE: 'COLORDIR - builds a color FMS directory string'
  1981. ' $PAGE
  1982. '
  1983. '  NAME    --  COLORDIR
  1984. '
  1985. '  INPUTS  --  PARAMETER                   MEANING
  1986. '               STRNG$              String to alter
  1987. '               FMS.DIR$            "Y" FOR FMS DIR
  1988. '                                   "N" FOR PERSONAL DOWNLOADS
  1989. '
  1990.       SUB COLORDIR (STRNG$,FMS.DIR$) STATIC
  1991.       IF GR < 2 THEN _
  1992.          EXIT SUB
  1993.       IF FMS.DIR$ = "N" THEN _
  1994.          GOTO 59921
  1995. '
  1996. ' INSERT COLOR FOR FILENAME
  1997. '
  1998.       ON INSTR("\ *",LEFT$(STRNG$,1)) GOTO 59924,59922,59923
  1999. 59921 STRNG$ = DR.1$ + LEFT$(STRNG$,13) + DR.2$ + MID$(STRNG$,14,10) + _
  2000.                DR.3$ + MID$(STRNG$,24,10) + DR.4$ + MID$(STRNG$,34,MAX.DESC.LEN)
  2001.       EXIT SUB
  2002. 59922 STRNG$ = DR.4$ + STRNG$
  2003.       EXIT SUB
  2004. 59923 STRNG$ = EMPHASIZE.OFF$ + STRNG$
  2005. 59924 END SUB
  2006. 59930 ' $SUBTITLE: 'CHKCOLOR - highlights based on search string'
  2007. ' $PAGE
  2008. '
  2009. '  NAME    --  CHKCOLOR
  2010. '
  2011. '  INPUTS  --  PARAMETER                   MEANING
  2012. '              LOOK.FOR$           String that triggers highlight
  2013. '              LOOK.IN$            String being searched
  2014. '              END.COLOR$          Terminating color
  2015. '
  2016. '  OUTPUTS --  STRNG$              Revised string
  2017. '
  2018. '  PURPOSE --  Adds highlighting to a string within a string.
  2019. '              Respects previous colorization.
  2020.       SUB CHKCOLOR (LOOK.IN$,LOOK.FOR$,PASSED.END.COLOR$) STATIC
  2021.       IF LOOK.FOR$ = "" THEN _
  2022.          EXIT SUB
  2023.       X$ = LOOK.IN$
  2024.       CALL ALLCAPS (X$)
  2025.       START.COLOR = INSTR(X$,LOOK.FOR$)
  2026.       IF START.COLOR < 1 THEN _
  2027.          EXIT SUB
  2028.       END.COLOR$ = PASSED.END.COLOR$
  2029.       IF END.COLOR$ = "" THEN _
  2030.          END.COLOR$ = EMPHASIZE.OFF$ : _
  2031.          CALL FINDLAST (LEFT$(LOOK.IN$,START.COLOR-1),ESCAPE$,WHERE.FOUND,J) : _
  2032.          IF WHERE.FOUND > 0 THEN _
  2033.             J = INSTR(WHERE.FOUND,LOOK.IN$,"m") : _
  2034.             IF J > 0 THEN _
  2035.                END.COLOR$ = MID$(LOOK.IN$,WHERE.FOUND,J-WHERE.FOUND+1)
  2036.       CALL BRACKET (LOOK.IN$,START.COLOR,START.COLOR + LEN(LOOK.FOR$)-1,EMPHASIZE.ON$,END.COLOR$)
  2037.       END SUB
  2038. 59934 ' $SUBTITLE: 'SETHILITE - subroutine to reset highlight preference'
  2039. ' $PAGE
  2040. '
  2041. '  NAME    --  SETHILITE
  2042. '
  2043. '  INPUTS  --  PARAMETER                   MEANING
  2044. '              SET.TO              New value (True or False)
  2045. '              EMPHASIZE.ON.DEF$   String turns emphasize on
  2046. '              EMPHASIZE.OFF.DEF$  String turns emphasize off
  2047. '
  2048. '  OUTPUTS --  HIGHLIGHT.OFF       Callers preference on Hilite
  2049. '              EMPHASIZE.ON$       String to use for emphasis
  2050. '              EMPHASIZE.OFF$      String to use after emphasis
  2051. '
  2052.       SUB SETHILITE (SET.TO) STATIC
  2053.       HIGHLIGHT.OFF = (EMPHASIZE.ON.DEF$ <> "" AND SET.TO)
  2054.       IF HIGHLIGHT.OFF THEN _
  2055.          EMPHASIZE.ON$ = "" : _
  2056.          EMPHASIZE.OFF$ = "" : _
  2057.          FG.1$ = "" : _
  2058.          FG.2$ = "" : _
  2059.          FG.3$ = "" : _
  2060.          FG.4$ = "" _
  2061.       ELSE EMPHASIZE.ON$ = EMPHASIZE.ON.DEF$ : _
  2062.            FG.1$ = FG.1.DEF$ : _
  2063.            FG.2$ = FG.2.DEF$ : _
  2064.            FG.3$ = FG.3.DEF$ : _
  2065.            FG.4$ = FG.4.DEF$
  2066.       END SUB
  2067. 59940 ' $SUBTITLE: 'COLORPMT - subroutine to colorize prompts'
  2068. ' $PAGE
  2069. '
  2070. '  NAME    --  COLORPMT
  2071. '
  2072. '  INPUTS  --  PARAMETER                   MEANING
  2073. '              STRNG$              String to colorize
  2074. '              HIGHLIGHT.OFF       Whether highlighting is off
  2075. '              EMPHASIZE.ON$       String to use for emphasis
  2076. '              EMPHASIZE.OFF$      String to use after emphasis
  2077. '
  2078. '  OUTPUTS --  STRNG$              Colorized string
  2079. '
  2080. '  PURPOSE -- colorizes a string based on sysop settings
  2081. '             and the string.
  2082. '                        [...] is the default - put in emphasis
  2083. '                        <...> options to type - put in FG.4$
  2084. '                           and first two precedign words use FG.1$ and FG.2$
  2085. '                        options identified on right by ) and on
  2086. '                           left by space or comma - put in FG.4$
  2087. '
  2088.       SUB COLORPMT (STRNG$) STATIC
  2089.       IF HIGHLIGHT.OFF THEN _
  2090.          EXIT SUB
  2091.       ALREADY.COLORIZED = (INSTR(STRNG$,ESCAPE$) > 0)
  2092.       X = INSTR(STRNG$,"<")
  2093.       IF X > 0 THEN _
  2094.          GOTO 59943
  2095.       X = INSTR(STRNG$,"[")   ' highlight default
  2096.       IF X > 0 THEN _
  2097.          Y = INSTR(X,STRNG$,"]") : _
  2098.          IF Y > 0 THEN _
  2099.             CALL BRACKET (STRNG$,X,Y,EMPHASIZE.ON$,EMPHASIZE.OFF$)
  2100.       IF ALREADY.COLORIZED THEN _
  2101.          EXIT SUB
  2102.       X = INSTR(STRNG$,"<")
  2103.       IF X < 1 THEN _
  2104.          GOTO 59945
  2105. 59943 Y = INSTR(X,STRNG$,">")
  2106.       IF Y < 1 THEN _
  2107.          GOTO 59945
  2108.       CALL BRACKET (STRNG$,X,Y,FG.4$,EMPHASIZE.OFF$)
  2109.       Y = INSTR(STRNG$," ")
  2110.       IF Y > 1 AND Y < X THEN _
  2111.          STRNG$ = FG.1$ + STRNG$ : _
  2112.          Z = INSTR(Y+1,STRNG$," ") : _
  2113.          IF Z > 1 AND Z < X+LEN(FG.1$) THEN _
  2114.             STRNG$ = LEFT$(STRNG$,Z) + FG.2.DEF$ + MID$(STRNG$,Z+1)
  2115.       EXIT SUB
  2116. 59945 X = 1
  2117.       DID.INSERT = FALSE
  2118.       L = LEN(FG.4$)
  2119. 59950 Y = INSTR (X,STRNG$,")")  ' x: where command begins, y: terminating pos
  2120.       Z = INSTR (X,STRNG$,",")
  2121.       IF Y = 0 OR (Z > 0 AND Z < Y) THEN _
  2122.          Y = Z
  2123.       K = LEN(STRNG$)
  2124.       IF X > K THEN _
  2125.          EXIT SUB
  2126.       IF Y < 1 THEN _
  2127.          IF NOT DID.INSERT THEN _
  2128.             EXIT SUB _
  2129.          ELSE Y = K+1
  2130.       Z = Y - 1
  2131.       WHILE Z > 0    ' got terminating pos: find beginning
  2132.          IF INSTR(OPTION.END$,MID$(STRNG$,Z,1)) > 0 THEN _
  2133.             X = Z + 1 : _
  2134.             Z = 0
  2135.          Z = Z - 1
  2136.       WEND
  2137.       IF Y-X < 3 THEN _     ' exclude commands too long
  2138.          CMND.STRNG$ = MID$(STRNG$,X,Y-X) : _
  2139.          X$ = CMND.STRNG$ : _
  2140.          CALL ALLCAPS (CMND.STRNG$) : _
  2141.          IF X$ = CMND.STRNG$ THEN _  ' exclude lower case
  2142.             DID.INSERT = TRUE : _
  2143.             CALL BRACKET (STRNG$,X,Y-1,FG.4$,EMPHASIZE.OFF$) : _  ' colorize
  2144.             Y = Y + L
  2145.       X = Y + 1
  2146.       GOTO 59950
  2147.       END SUB
  2148. 59960 ' $SUBTITLE: 'BRACKET - Inserts strings around a string'
  2149. ' $PAGE
  2150. '
  2151. '  NAME    --  BRACKET
  2152. '
  2153. '  INPUTS  --  PARAMETER                   MEANING
  2154. '              STRNG$              Insert in this string
  2155. '              B4.HERE             Insert 1st before this pos
  2156. '              AFTER.HERE          Insert 2nd after this pos
  2157. '              B4.STRNG$           String to insert before
  2158. '              AFTER.STRNG$        String to insert after
  2159. '
  2160. '  OUTPUTS --  STRNG$
  2161. '
  2162. '  PURPOSE -- Primarily for colorization
  2163. '
  2164.       SUB BRACKET (STRNG$,B4.HERE,AFTER.HERE,B4.STRNG$,AFTER.STRNG$) STATIC
  2165.       STRNG$ = LEFT$(STRNG$,B4.HERE-1) + _
  2166.                B4.STRNG$ + _
  2167.                MID$(STRNG$,B4.HERE,AFTER.HERE-B4.HERE+1) + _
  2168.                AFTER.STRNG$ + _
  2169.                RIGHT$(STRNG$,LEN(STRNG$) - AFTER.HERE)
  2170.       END SUB
  2171. 59965 ' $SUBTITLE: 'USERCOLOR - lets user set color for normal text'
  2172. ' $PAGE
  2173. '
  2174. '  NAME    --  USERCOLOR
  2175. '
  2176. '  INPUTS  --  PARAMETER                   MEANING
  2177. '              EMPHASIZE.OFF$      Normal text color
  2178. '
  2179. '  OUTPUTS --  EMPHASIZE.OFF$      New text color
  2180. '              BOLD.TEXT$          Whether bold (0 not, 1 bold)
  2181. '              USER.TEXT.COLOR     ANSI Color selected
  2182. '
  2183. '  PURPOSE --  Lets caller select desired color and whether bold.
  2184. '
  2185.       SUB USERCOLOR STATIC
  2186.       IF HIGHLIGHT.OFF THEN _
  2187.          EXIT SUB
  2188. 59970 CALL QTPUT (EMPHASIZE.OFF$,0)
  2189.       A$ = "Make text R)ed,G)reen,Y)ellow,B)lue,P)urple,C)yan,W)hite" + PRESS.ENTER.EXPERT$
  2190.       GOSUB 59973
  2191.       IF Q = 0 THEN _
  2192.          EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _
  2193.              ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m" : _
  2194.          EXIT SUB
  2195.       CALL ALLCAPS (B$)
  2196.       X = INSTR("RGYBPCW",B$)
  2197.       IF X = 0 THEN _
  2198.          GOTO 59970
  2199.       USER.TEXT.COLOR = 30 + X
  2200.       A$ = "Make text BOLD (Y,[N])"
  2201.       GOSUB 59973
  2202.       BOLD.TEXT$ = CHR$(48 - YES)
  2203.       EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m"
  2204.       GOTO 59970
  2205. 59973 SUBROUTINE.PARAMETER = 1
  2206.       TURBO.KEY = -TURBO.KEY.USER
  2207.       CALL TGET
  2208.       IF SUBROUTINE.PARAMETER = -1 THEN _
  2209.          EXIT SUB
  2210.       RETURN
  2211.       END SUB
  2212. 59980 ' $SUBTITLE: 'SETUGD - Sets user graphic preference'
  2213. ' $PAGE
  2214. '
  2215. '  NAME    --  SETUGD
  2216. '
  2217. '  INPUTS  --  PARAMETER                   MEANING
  2218. '              GRAPHICS.NUMBER   0=None, 1=Ascii, 2=color
  2219. '
  2220. '  OUTPUTS --  GR                Shared var - set to
  2221. '                                graphics.number
  2222. '              GRAPHICS.LETTER$  What add to file name to
  2223. '                                see if got graphics file ver
  2224. '
  2225. '  PURPOSE --  Sets file graphics preference
  2226. '
  2227.       SUB SETUGD (GRAPHICS.NUMBER,GRAPHICS.LETTER$) STATIC
  2228.       GR = GRAPHICS.NUMBER
  2229.       IF GR = 2 THEN _
  2230.          DR.1$ = FG.1.DEF$ : _
  2231.          DR.2$ = FG.2.DEF$ : _
  2232.          DR.3$ = FG.3.DEF$ : _
  2233.          DR.4$ = FG.4.DEF$ _
  2234.       ELSE DR.1$ = "" : _
  2235.            DR.2$ = "" : _
  2236.            DR.3$ = "" : _
  2237.            DR.4$ = ""
  2238.       GRAPHICS.LETTER$ = MID$(" GC",GR+1, - (GR > 0))
  2239.       END SUB
  2240. 60000 ' $SUBTITLE: 'EOFCOMM - Determines whether input in comm port buffer'
  2241. ' $PAGE
  2242. '
  2243. '  NAME    --  EOFCOMM
  2244. '
  2245. '  INPUTS  --  PARAMETER                   MEANING
  2246. '               FOSSIL              Whether fossil driver used
  2247. '               COMPORT%            Comm port # in use
  2248. '
  2249. '  OUTPUTS --  NOCHARS%           -1 (TRUE) if no chars in buffer.
  2250. '                                             Anything else means has char.
  2251. '
  2252. '  PURPOSE -- Query comm port to see if input waiting
  2253. '
  2254.       SUB EOFCOMM (NOCHARS%) STATIC
  2255.       IF FOSSIL THEN _
  2256.          CALL FOSREADAHEAD(COMPORT%,NOCHARS%) _
  2257.       ELSE NOCHARS% = EOF(3)
  2258.       END SUB
  2259. 60100 ' $SUBTITLE: 'GSANDR - Global search and replace'
  2260. ' $PAGE
  2261. '
  2262. '  NAME    --  GSANDR
  2263. '
  2264. '  INPUTS  --  PARAMETER                   MEANING
  2265. '              STRNG$              String to edit
  2266. '              LOOK.FOR$           String to look for
  2267. '              REPLACE.BY$         String to replace by
  2268. '
  2269. '  OUTPUTS --  STRNG$              Edited string
  2270. '
  2271. '  PURPOSE --  Replaces every occurence of LOOK.FOR$ that
  2272. '                         is in STRNG$ by REPLACE.BY$
  2273. '
  2274.       SUB GSANDR (STRNG$,LOOK.FOR$,REPLACE.BY$,OVERSTRIKE) STATIC
  2275.       IF LOOK.FOR$ = "" THEN _
  2276.          EXIT SUB
  2277.       X = 1
  2278.       L = LEN(REPLACE.BY$)
  2279.       M = LEN(LOOK.FOR$)
  2280. 60102 Y = INSTR(X,STRNG$,LOOK.FOR$)
  2281.       IF Y < 1 THEN _
  2282.          EXIT SUB
  2283.       IF OVERSTRIKE THEN _
  2284.          MID$(STRNG$,Y) = REPLACE.BY$ + SPACE$((L-M)*(L < M)) _
  2285.       ELSE STRNG$ = LEFT$(STRNG$,Y-1) + _
  2286.                     REPLACE.BY$ + _
  2287.                     RIGHT$(STRNG$,LEN(STRNG$)-Y+1-M)
  2288.       X = Y + L
  2289.       IF X > LEN(STRNG$) THEN _
  2290.          EXIT SUB
  2291.       GOTO 60102
  2292.       END SUB
  2293. 60130 ' $SUBTITLE: 'METAGSR -- Meta Global search and replace'
  2294. ' $PAGE
  2295. '
  2296. '  NAME    --  METAGSR
  2297. '
  2298. '  INPUTS  --  PARAMETER               MEANING
  2299. '              STRNG$              String to edit
  2300. '
  2301. '  OUTPUTS --  STRNG$              Edited string
  2302. '
  2303. '  PURPOSE --  Global search and replace for meta variables
  2304. '
  2305.       SUB METAGSR (STRNG$,OVERSTRIKE) STATIC
  2306.       Y = 1
  2307. 60131 IF Y > LEN(STRNG$) THEN _
  2308.          EXIT SUB
  2309.       X = INSTR(Y,STRNG$,"[")
  2310.       IF X = 0 THEN _
  2311.          EXIT SUB
  2312.       Y = INSTR(X,STRNG$,"]")
  2313.       IF Y = 0 THEN _
  2314.          EXIT SUB
  2315.       M = Y-X+1
  2316.       TEMP = Y-X-1
  2317.       CALL CHECKINT(MID$(STRNG$,X+1,TEMP))
  2318.       IF (EC > 0) OR (TESTED.INTEGER.VALUE < 1) OR (TESTED.INTEGER.VALUE > MAX.WORK.VAR) THEN _
  2319.          GOTO 60135
  2320.       IF ((TESTED.INTEGER.VALUE < 10) AND (TEMP = 1)) OR ((TESTED.INTEGER.VALUE > 9) AND (TEMP = 2)) THEN _
  2321.          GOTO 60132
  2322.       Y = X + 1
  2323.       GOTO 60131
  2324. 60132 WORK.HOLD$ = GSR.ARA$(TESTED.INTEGER.VALUE)
  2325.       IF Y = LEN(STRNG$) THEN _
  2326.          GOTO 60151
  2327.       IF MID$(STRNG$,Y+1,1) <> "(" THEN _
  2328.          GOTO 60151
  2329.       I = INSTR(Y+1,STRNG$,")")
  2330.       IF I = 0 THEN _
  2331.          GOTO 60151
  2332.       J = INSTR(Y+1,STRNG$,":")
  2333.       IF J > I THEN _
  2334.          GOTO 60151
  2335.       CALL CHECKINT (MID$(STRNG$,Y+2))
  2336.       IF (EC > 0) OR (TESTED.INTEGER.VALUE < 1) OR _
  2337.          (TESTED.INTEGER.VALUE > LEN(WORK.HOLD$)) THEN _
  2338.             GOTO 60151
  2339.       Y = I
  2340.       M = I-X+1
  2341.       STRT.SUB = TESTED.INTEGER.VALUE
  2342.       CALL CHECKINT (MID$(STRNG$,J+1))
  2343.       IF EC > 0 OR TESTED.INTEGER.VALUE < 1 OR _
  2344.          (TESTED.INTEGER.VALUE > LEN(WORK.HOLD$)) THEN _
  2345.             GOTO 60151
  2346.       LEN.SUB = TESTED.INTEGER.VALUE
  2347.       WORK.HOLD$ = MID$(WORK.HOLD$,STRT.SUB,LEN.SUB)
  2348.       GOTO 60151
  2349. 60135 META.VAL$ = MID$(STRNG$,X+1,Y-X-1)
  2350.       I = INSTR("      BAUD  PORT  PORT# PARITYPROTO NODE  FILE  ",META.VAL$)
  2351.       IF I = 0 OR LEN(META.VAL$) < 4 THEN _                          ' KG071901
  2352.          Y = X + 1 : _
  2353.          GOTO 60131
  2354.       J = (I-1)\6 + 1
  2355.       K = (I+4)\6 + 1
  2356.       IF K > J THEN _
  2357.          EXIT SUB
  2358.       ON J GOTO 60155, _
  2359.                 60137, _
  2360.                 60139, _
  2361.                 60141, _
  2362.                 60143, _
  2363.                 60145, _
  2364.                 60147, _
  2365.                 60149, _
  2366.                 60151
  2367. 60137 WORK.HOLD$ = TALK.TO.MODEM.AT$
  2368.       GOTO 60151
  2369. 60139 WORK.HOLD$ = COM.PORT$
  2370.       GOTO 60151
  2371. 60141 WORK.HOLD$ = MID$(COM.PORT$,4)
  2372.       GOTO 60151
  2373. 60143 WORK.HOLD$ = MID$(BAUD.PARITY$,INSTR(BAUD.PARITY$,",")+1,1)
  2374.       GOTO 60151
  2375. 60145 WORK.HOLD$ = FT$
  2376.       GOTO 60151
  2377. 60147 WORK.HOLD$ = NODE.ID$
  2378.       GOTO 60151
  2379. 60149 IF BATCH.TRANSFER THEN _
  2380.          WORK.HOLD$ = "@" + NODE.WORK.FILE$ _
  2381.       ELSE WORK.HOLD$ = FILE.NAME$
  2382.       GOTO 60151
  2383. 60151 L = LEN(WORK.HOLD$)
  2384.       IF OVERSTRIKE THEN _
  2385.          MID$(STRNG$,X) = WORK.HOLD$ + SPACE$((L-M)*(L < M)) _
  2386.       ELSE STRNG$ = LEFT$(STRNG$,X-1) + WORK.HOLD$ + RIGHT$(STRNG$,LEN(STRNG$)-Y)
  2387.       Y = 1 ' Y = X + L
  2388.       GOTO 60131
  2389. 60155 Y = Y + 1
  2390.       GOTO 60131
  2391.       END SUB
  2392. 60180 ' $SUBTITLE: 'TIMELOCK - Test TIME LOCK for premium features'
  2393. ' $PAGE
  2394. '
  2395. '  NAME    --  TIMELOCK  (written by Doug Azzarito)
  2396. '
  2397. '  INPUTS  --  PARAMETER                   MEANING
  2398. '              TIME.LOCK.SET               SECONDS/SESSION TO LOCK
  2399. '
  2400. '  OUTPUTS --  SUBROUTINE.PARAMETER     -1 if feature is LOCKED
  2401. '
  2402. '  PURPOSE -- Check elapsed time for lock duration
  2403. '
  2404.       SUB TIMELOCK STATIC
  2405.       CALL TIMEREMAIN(TIME.REMAINING!)
  2406.       IF TCA! > TIME.LOCK.SET THEN _
  2407.          OK = TRUE : _
  2408.          EXIT SUB
  2409.       CALL BUFFILE(HELP.PATH$+"TIMELOCK"+HELP.EXTENSION$,X)
  2410.       IF NOT OK THEN _
  2411.          CALL QTPUT1 ("Sorry, " + FIRST.NAME$ + _
  2412.                     ", function unavailable for first" + _
  2413.                     STR$(TIME.LOCK.SET) + "seconds")
  2414.       OK = FALSE
  2415.       END SUB
  2416. 60200 ' $SUBTITLE: 'MARKTIME - Give feedback for lengthy processes'
  2417. ' $PAGE
  2418. '
  2419. '  NAME    --  MARKTIME
  2420. '
  2421. '  INPUTS  --  PARAMETER                   MEANING
  2422. '              DOT.NUMBER          How many dots printed
  2423. '
  2424. '  OUTPUTS --  DOT.NUMBER
  2425. '
  2426. '  PURPOSE --  Marks time by putting colorized dots out
  2427. '              to 4, then erasing
  2428. '
  2429.       SUB MARKTIME (DOT.NUMBER) STATIC
  2430.       CALL FINDTIME (TI!)
  2431.       IF TI! - PREV.TI! < 1.0 THEN _
  2432.          EXIT SUB
  2433.       PREV.TI! = TI!
  2434.       IF REMOVE.DOT AND DOT.NUMBER > 0 THEN _
  2435.          CALL QTPUT (BACKSPACE$,0) : _
  2436.          DOT.NUMBER = DOT.NUMBER - 1 : _
  2437.          EXIT SUB
  2438.       DOT.NUMBER = DOT.NUMBER + 1
  2439.       ON DOT.NUMBER GOTO 60201,60202,60203,60204
  2440. 60201 X$ = FG.1$
  2441.       REMOVE.DOT = FALSE
  2442.       GOTO 60205
  2443. 60202 X$ = FG.2$
  2444.       GOTO 60205
  2445. 60203 X$ = FG.3$
  2446.       GOTO 60205
  2447. 60204 X$ = FG.4$
  2448.       REMOVE.DOT = TRUE
  2449. 60205 CALL QTPUT (X$ + "." + EMPHASIZE.OFF$,0)
  2450.       END SUB
  2451. 60300 ' $SUBTITLE: 'AUTOPAGE - NOTIFIES SYSOP WHEN SPECIFIC USER CALLS'
  2452. ' $PAGE
  2453. '
  2454. '  NAME    --  AUTOPAGE   'Contributed  by Gregg and Bob Snyder
  2455. '                        'and RoseMarie Siddiqui
  2456. '
  2457. '  INPUTS  --  AUTOPAGE.DEF$  List of conditions that trigger
  2458. '                                       notification and how
  2459. '
  2460. '  OUTPUTS -- NONE
  2461. '
  2462. '  PURPOSE -- Search AUTOPAGE.DEF$ for match on whether
  2463. '             on name, security level, whether new user.
  2464. '             Also controls whether caller notified and
  2465. '             number of times sysop has bell rung.
  2466. '             And what tune to play (if any).
  2467. '
  2468.       SUB AUTOPAGE STATIC
  2469.       CALL FINDIT (AUTOPAGE.DEF$)
  2470.       IF NOT OK THEN _
  2471.          EXIT SUB
  2472.       EC = 0
  2473.       OK = FALSE
  2474.       WHILE NOT EOF(2) AND OK = FALSE AND EC = 0
  2475.          CALL READPARMS (WORK.ARA$(),4,1)
  2476.          IF EC = 0 THEN _
  2477.             OK = (WORK.ARA$(1) = ACTIVE.USER.NAME$) : _
  2478.             IF NOT OK THEN _
  2479.                IF NEW.USER AND WORK.ARA$(1) = "NEWUSER" THEN _
  2480.                   OK = TRUE _
  2481.                ELSE IF LEFT$(WORK.ARA$(1),1) = "/" AND LEN(WORK.ARA$(1)) > 2 THEN _
  2482.                        B = INSTR (2,WORK.ARA$(1),"/") : _
  2483.                        IF B > 0 AND LEN(WORK.ARA$(1)) > B THEN _
  2484.                           IF USER.SECURITY.LEVEL <= VAL(MID$(WORK.ARA$(1),B+1)) AND _
  2485.                              USER.SECURITY.LEVEL >= VAL(MID$(WORK.ARA$(1),2)) THEN _
  2486.                                 OK = TRUE
  2487.       WEND
  2488.       CLOSE 2
  2489.       IF EC > 0 OR NOT OK THEN _
  2490.          EC = 0 : _
  2491.          EXIT SUB
  2492.       PAGE.STATUS$ = "AutoPaged!"
  2493.       IF LEFT$(WORK.ARA$(2),1) = "N" THEN _
  2494.          A$ = "Notifying sysop of your presence" : _
  2495.          CALL RINGCALLER
  2496.       B = (WORK.ARA$(4) = "")
  2497.       WORK.ARA$(5) = ""
  2498.       FOR I = 1 TO VAL(WORK.ARA$(3))
  2499.          IF B THEN _
  2500.             CALL LPRNT (BELL.RINGER$,0) : _
  2501.          ELSE WORK.ARA$(5) = WORK.ARA$(5) + "O4 X" + VARPTR$(WORK.ARA$(4))
  2502.       NEXT
  2503.       IF NOT B THEN _
  2504.          CALL RBBSPLAY (WORK.ARA$(5))
  2505.       END SUB
  2506. 62520 ' $SUBTITLE: 'PUTMATTR - subroutine to save msg. attributes'
  2507. ' $PAGE
  2508. '
  2509. '  NAME    --  PUTMATTR
  2510. '
  2511. '  INPUTS  --  PARAMETER                   MEANING
  2512. '              Q
  2513. '              B$
  2514. '              LINES.IN.MESSAGE
  2515. '              S
  2516. '              NON.STOP
  2517. '              MESSAGE.DIM.INDEX
  2518. '
  2519. '  OUTPUTS --  SQ
  2520. '              LG$(10)
  2521. '              LINES.IN.MESSAGE.SAVE
  2522. '              SL
  2523. '              NON.STOP.SAVE
  2524. '              MESSAGE.DIM.INDEX.SAVE
  2525. '
  2526. '  PURPOSE --  WHEN REPLYING TO A MESSAGE THIS ROUTINE SAVES
  2527. '              THE ATTRIBUTES OF THE ORGINAL MESSAGE
  2528. '
  2529.       SUB PUTMATTR STATIC
  2530.       SQ = Q
  2531.       LG$(10) = B$
  2532.       LINES.IN.MESSAGE.SAVE = LINES.IN.MESSAGE
  2533.       SL = S
  2534.       NON.STOP.SAVE = NON.STOP
  2535.       MESSAGE.DIM.INDEX.SAVE = MESSAGE.DIM.INDEX
  2536.       END SUB
  2537. 62530 ' $SUBTITLE: 'GETMATTR - subroutine to get msg. attributes'
  2538. ' $PAGE
  2539. '
  2540. '  NAME    --  GETMATTR
  2541. '
  2542. '  INPUTS  --  PARAMETER                   MEANING
  2543. '              SQ
  2544. '              LG$(10)
  2545. '              LINES.IN.MESSAGE.SAVE
  2546. '              SL
  2547. '              NON.STOP.SAVE
  2548. '              MESSAGE.DIM.INDEX.SAVE
  2549. '
  2550. '  OUTPUTS --  Q
  2551. '              B$
  2552. '              LINES.IN.MESSAGESAVE
  2553. '              S
  2554. '              NON.STOP
  2555. '              MESSAGE.DIM.INDEX
  2556. '              KILL.MESSAGE
  2557. '
  2558. '  PURPOSE --  After replying to a message this routine restores
  2559. '              the attributes of the orginal message
  2560. '
  2561.       SUB GETMATTR STATIC
  2562.       Q = SQ
  2563.       B$ = LG$(10)
  2564.       LINES.IN.MESSAGE = LINES.IN.MESSAGE.SAVE
  2565.       S = SL
  2566.       NON.STOP = NON.STOP.SAVE
  2567.       MESSAGE.DIM.INDEX = MESSAGE.DIM.INDEX.SAVE
  2568.       KILL.MESSAGE = FALSE
  2569.       END SUB
  2570. 62540 ' $SUBTITLE: 'RPTTIME -- Reports time on system'
  2571. ' $PAGE
  2572. '
  2573. '  NAME    --  RPTTIME
  2574. '
  2575. '  INPUTS  --  PARAMETER                   MEANING
  2576. '
  2577. '  OUTPUTS --
  2578. '
  2579. '  PURPOSE --  Tells user time used on system
  2580. '
  2581.       SUB RPTTIME STATIC
  2582.       CALL SKIPLINE (1)
  2583.       CALL GETIME                                                    ' KG061203
  2584.       CALL AMORPM
  2585.       QX = ((HHH * 60) + MMM + (SSS / 60.0)) * 10.0
  2586.       Q! = QX / 10.0
  2587.       MINS = (HHH * 60) + MMM
  2588.       CALL CARRIER
  2589.       IF SUBROUTINE.PARAMETER = -1 THEN _
  2590.          EXIT SUB
  2591.       CALL QTPUT1 ("Now: " + DATE$ + " at " + TIME$)
  2592.       CALL QTPUT1 ("On for" + STR$(MINS) + " mins," + STR$(SSS) + " secs")
  2593.       CALL TALK (7,A$)
  2594.       END SUB
  2595. 62600 ' $SUBTITLE: 'PROTOCOL - Determine protocols available'
  2596. ' $PAGE
  2597. '
  2598. '  NAME    -- PROTOCOL
  2599. '
  2600. '  INPUTS  --     PARAMETER                    MEANING
  2601. '                 PROTO.DEF$                File of installed protocols
  2602. '
  2603. '  OUTPUTS -- TRANSFER.OPTIONS$         Prompt for protocol choice
  2604. '             DFLTXFER$                 Letters of protocols
  2605. '             INTERNAL.EQUIV$           Internal protocol to use
  2606. '
  2607. '  PURPOSE -- TO determine what protocols are available to user
  2608. '
  2609.       SUB PROTOCOL STATIC
  2610.       CALL FINDIT (PROTO.DEF$)
  2611.       IF NOT OK THEN _
  2612.          TRANSFER.OPTIONS$ = "A)scii,X)modem,C)rcXmodem,Y)modem" : _
  2613.          INTERNAL.EQUIV$ = "AXCY" : _
  2614.          DFLTXFER$ = "AXCY" : _
  2615.          GOTO 62604
  2616.       DFLTXFER$ = ""
  2617.       INTERNAL.EQUIV$ = ""
  2618.       TRANSFER.OPTIONS$ = ""
  2619.       L = 0
  2620. 62602 IF EOF(2) THEN _
  2621.          GOTO 62604
  2622.       CALL READPARMS (WORK.ARA$(),13,1)
  2623.       IF EC > 0 THEN _
  2624.          EXIT SUB
  2625.       DFLTXFER$ = DFLTXFER$ + " "
  2626.       INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + " "
  2627.       IF USER.SECURITY.LEVEL < VAL(WORK.ARA$(2)) THEN _
  2628.          GOTO 62602
  2629.       IF LEFT$(WORK.ARA$(5),1) = "R" THEN _
  2630.          IF NOT RELIABLE.MODE THEN _
  2631.             GOTO 62602
  2632.       IF LEFT$(WORK.ARA$(3),1) = "I" THEN _
  2633.          GOTO 62603
  2634.       X = INSTR(WORK.ARA$(12)+" "," ")
  2635.       X$ = LEFT$(WORK.ARA$(12),X-1)
  2636.       CALL FINDFILE (X$,FOUND)
  2637.       IF FOUND THEN _
  2638.          X = INSTR(WORK.ARA$(13)+" "," ") : _
  2639.          X$ = LEFT$(WORK.ARA$(13),X-1) : _
  2640.          CALL FINDFILE (X$,FOUND)
  2641.       IF NOT FOUND THEN _
  2642.          GOTO 62602
  2643. 62603 MID$(DFLTXFER$,LEN(DFLTXFER$),1) = LEFT$(WORK.ARA$(1),1)
  2644.       CALL FINDLAST (WORK.ARA$(1),CRLF$,X,I)
  2645.       IF X > 0 AND X >= LEN(WORK.ARA$(1)) - 2 THEN _
  2646.          WORK.ARA$(1) = LEFT$(WORK.ARA$(1),X-1)
  2647.       IF (L + LEN(WORK.ARA$(1)) < 62) AND X = 0 THEN _
  2648.          TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + "," + WORK.ARA$(1) : _
  2649.          L = L + LEN(WORK.ARA$(1)) + 1 _
  2650.       ELSE L = LEN(WORK.ARA$(1)) : _
  2651.            TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + _
  2652.                               CRLF$ + _
  2653.                               WORK.ARA$(1)
  2654.       IF LEFT$(WORK.ARA$(3),1) = "I" AND RIGHT$(WORK.ARA$(3),1) <> "I" THEN _
  2655.          MID$(INTERNAL.EQUIV$,LEN(INTERNAL.EQUIV$),1) = RIGHT$(WORK.ARA$(3),1)
  2656.       GOTO 62602
  2657. 62604 IF INSTR(INTERNAL.EQUIV$,"N") > 0 THEN _
  2658.          GOTO 62605
  2659.       IF X = 0 THEN _
  2660.          TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + ",N)one" _
  2661.       ELSE TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + CRLF$ + "N)one"
  2662.       DFLTXFER$ = DFLTXFER$ + "N"
  2663.       INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + "N"
  2664. 62605 IF LEFT$(TRANSFER.OPTIONS$,1) = "," THEN _
  2665.          TRANSFER.OPTIONS$ = MID$(TRANSFER.OPTIONS$,2)
  2666.       IF INSTR(DFLTXFER$,USER.TRANSFER.DEFAULT$) = 0 THEN _
  2667.          CALL QTPUT1 ("Protocol "+USER.TRANSFER.DEFAULT$+" unavailable.  Default reset to None") : _
  2668.          USER.TRANSFER.DEFAULT$ = MID$(DFLTXFER$,INSTR(INTERNAL.EQUIV$,"N"),1)
  2669.       END SUB
  2670. 62620 ' $SUBTITLE: 'TRANSFER - Subroutine for external protocols'
  2671. ' $PAGE
  2672. '
  2673. '  NAME    -- TRANSFER
  2674. '
  2675. '  INPUTS  --     PARAMETER                    MEANING
  2676. '              TRANSFER.FUNCTION         = 1 DOWNLOAD FILE TO USER
  2677. '                                        = 2 UPLOAD FILE TO RBBS-PC
  2678. '              FILE.NAME$                NAME OF FILE FOR TRANSFER
  2679. '              COM.PORT$                 NAME OF COMMUNICATIONS PORT
  2680. '                                        TO BE USED BY KERMIT (COM1
  2681. '                                        OR COM2)
  2682. '              BPS                       = -1 FOR   300 BAUD
  2683. '                                        = -2 FOR   450 BAUD
  2684. '                                        = -3 FOR  1200 BAUD
  2685. '                                        = -4 FOR  2400 BAUD
  2686. '                                        = -5 FOR  4800 BAUD
  2687. '                                        = -6 FOR  9600 BAUD
  2688. '                                        = -7 FOR 19200 BAUD
  2689. '
  2690. '  OUTPUTS  -- NONE
  2691. '
  2692. '  PURPOSE -- To transfer files using external protocols
  2693. '
  2694.       SUB TRANSFER STATIC
  2695.       IF PRIVATE.DOOR THEN _
  2696.          CALL XFRETURN : _
  2697.          EXIT SUB
  2698.       IF TRANSFER.FUNCTION = 1 THEN _
  2699.          B$ = DOWN.TEMPLATE$ : _
  2700.          Z$ = "send " _
  2701.       ELSE IF TRANSFER.FUNCTION = 2 THEN _
  2702.               B$ = UP.TEMPLATE$ : _
  2703.               Z$ = "receive "
  2704.       CALL METAGSR (B$,FALSE)
  2705.       CALL QTPUT1 ("Protocol     : "+PROTO.PROMPT$)
  2706.       CALL QTPUT ("Ready to " + Z$ + " ",0)
  2707.       IF BATCH.TRANSFER THEN _
  2708.          CALL QTPUT1 ("(BATCH)") : _
  2709.          CALL OPENWORK (2,NODE.WORK.FILE$) : _
  2710.          WHILE NOT EOF(2) : _
  2711.            CALL READANY : _
  2712.            CALL BRKFNAME (A$,Z$,Y$,X$,TRUE) : _
  2713.            CALL QTPUT1 ("   "+Y$+X$) : _
  2714.          WEND _
  2715.       ELSE CALL QTPUT1 (FILE.NAME.HOLD$)
  2716.       CALL XFRETURN
  2717.       END SUB
  2718. 62624 ' $SUBTITLE: 'XFRETURN - subroutine to exit as a private door.'
  2719. ' $PAGE
  2720. '
  2721. '  NAME    -- XFRETURN
  2722. '
  2723. '  INPUTS  --     PARAMETER                    MEANING
  2724. '              TRANSFER.FUNCTION         = 1 DOWNLOAD FILE TO USER
  2725. '                                        = 2 UPLOAD FILE TO RBBS-PC
  2726. '                                        = 3 USER REGISTRATION PGM
  2727. '              B$                        NAME OF FILE TO EXIT TO
  2728. '              COM.PORT$                 NAME OF COMMUNICATIONS PORT
  2729. '                                        TO BE USED BY KERMIT (COM1
  2730. '                                        OR COM2)
  2731. '              BPS                       = -1 FOR   300 BAUD
  2732. '                                        = -2 FOR   450 BAUD
  2733. '                                        = -3 FOR  1200 BAUD
  2734. '                                        = -4 FOR  2400 BAUD
  2735. '                                        = -5 FOR  4800 BAUD
  2736. '                                        = -6 FOR  9600 BAUD
  2737. '                                        = -7 FOR 19200 BAUD
  2738. '
  2739. '  OUTPUTS -- NONE
  2740. '
  2741. '  PURPOSE -- To transfer control to another program
  2742. '
  2743.       SUB XFRETURN STATIC
  2744.       IF PRIVATE.DOOR THEN _
  2745.          GOTO 62630
  2746.       IF FAKE.XRPT THEN _
  2747.          CALL FAKEXRPT (FT$)
  2748.       IF ADVANCE.PROTO.WRITE THEN _
  2749.          CALL OPENOUTW ("XFER-"+NODE.ID$+".DEF") : _
  2750.          IF EC < 1 THEN _
  2751.             CALL PRNTWRKA (FILE.NAME$+",,"+FT$) : _
  2752.             CLOSE 2
  2753.       IF PROTO.METHOD$ = "S" THEN _
  2754.          GOTO 62629
  2755. 62628 X$ = LEFT$(B$,INSTR(B$+" "," ")-1)
  2756.       IF X$ = "" THEN _
  2757.          EXIT SUB
  2758.       CALL FINDIT (X$)
  2759.       IF NOT OK THEN _
  2760.          A$ = "Missing door program" : _
  2761.          CALL UPDTCALR (A$ + " " + X$,1) : _
  2762.          SNOOP = TRUE : _
  2763.          CALL LPRNT (A$,1) : _
  2764.          EXIT SUB
  2765.       A$(1) = DISK.FOR.DOS$ + _
  2766.               "COMMAND /C " + _
  2767.               B$
  2768.       A$(2) = RBBS.BAT$
  2769.       PRIVATE.DOOR = TRUE
  2770.       CALL QTPUT1 ("Exiting to External Program for File Transfer")
  2771.       LOCATE 25,1
  2772.       CALL LPRNT(LINE.FEED$,0)
  2773.       CALL RBBSEXIT (A$(),2)
  2774. 62629 CALL SHELLEXIT (B$)
  2775. 62630 IF PRIVATE.DOOR THEN _
  2776.          CALL RESTORECOM : _
  2777.          CALL DELAYIT (7 + BPS) : _
  2778.          CALL QTPUT1 ("Reloading RBBS-PC.  Please be patient.")
  2779. 62631 CALL SKIPLINE (2)
  2780.       LOCATE 24,1
  2781. 62632 END SUB
  2782. 62650 ' $SUBTITLE: 'FAKEXRPT - subroutine to create fake xfer report'
  2783. ' $PAGE
  2784. '
  2785. '  NAME    --  FAKEXRPT
  2786. '
  2787. '  INPUTS  --  PARAMETER                   MEANING
  2788. '              FILE.NAME.HOLD$      FILE TO BE TRANSFERRED
  2789. '              PROTO.USED$          PROTOCOL USED
  2790. '
  2791. '  OUTPUTS --  WRITES OUT TRANSFER FILE REPORT
  2792. '
  2793. '  PURPOSE --  External protocol drivers that do not write
  2794. '              out a standard transfer report must have one
  2795. '              provided in order for "dooring" to external
  2796. '              protocols to work properly, since this file
  2797. '              is read upon returning from an external protocol.
  2798. '
  2799.       SUB FAKEXRPT (PROTO.USED$) STATIC
  2800.       CLOSE 2
  2801.       OPEN "O",2,"XFER-" + _
  2802.                  NODE.FILE.ID$ + _
  2803.                  ".DEF"
  2804.       PRINT #2,FILE.NAME$
  2805.       PRINT #2,
  2806.       PRINT #2,PROTO.USED$
  2807.       PRINT #2,"S"
  2808.       CLOSE 2
  2809.       END SUB
  2810. 62660 ' $SUBTITLE: 'SETEXPERT - subroutine to adjust for expert change'
  2811. ' $PAGE
  2812. '
  2813. '  NAME    --  SETEXPERT
  2814. '
  2815. '  INPUTS  --  PARAMETER                   MEANING
  2816. '              EXPERT.USER          WHETHER IS AN EXPERT
  2817. '
  2818. '  OUTPUTS --  MORE.PROMPT$         Pause prompt
  2819. '              PRESS.ENTER$         Prompt to press enter
  2820. '
  2821. '  PURPOSE --  External protocol drivers that do not write
  2822. '              out a standard transfer report must have one
  2823. '              provided in order for "DOORING" to external
  2824. '              protocols to work properly, since this file
  2825. '              is read upon returning from an external protocol.
  2826. '
  2827.       SUB SETEXPERT STATIC
  2828.       IF EXPERT.USER THEN _
  2829.          MORE.PROMPT$ = "More <[Y],N,C,A" : _
  2830.          PRESS.ENTER$ = PRESS.ENTER.EXPERT$ : _
  2831.          EXIT SUB
  2832.       MORE.PROMPT$ = "More [Y]es,N)o,C)ontinuous,A)bort"
  2833.       PRESS.ENTER$ = PRESS.ENTER.NOVICE$
  2834.       END SUB
  2835. 62668 ' $SUBTITLE: 'NEWPASWRD - subroutine to get new password'
  2836. ' $PAGE
  2837. '
  2838. '  NAME    --  NEWPASWRD
  2839. '
  2840. '  INPUTS  --  PARAMETER                   MEANING
  2841. '              PRMPT$               Prompt to display
  2842. '              DISALLOW.SPACES      Whether answer can have all spaces
  2843. '
  2844. '  OUTPUTS --  Z$                   Password
  2845. '
  2846. '  PURPOSE --  To get a new password.
  2847. '
  2848.       SUB NEWPASWRD (PRMPT$,DISALLOW.SPACES) STATIC
  2849. 62670 A$ = PRMPT$
  2850.       HIDDEN = TRUE
  2851.       SUBROUTINE.PARAMETER = 1
  2852.       CALL TGET
  2853.       HIDDEN = FALSE
  2854.       IF SUBROUTINE.PARAMETER < 0 OR Q = 0 THEN _
  2855.          EXIT SUB
  2856.       IF LEN(B$) > 15 THEN _
  2857.          CALL QTPUT1 ("15 chars max") : _
  2858.          GOTO 62670
  2859.       IF INSTR(B$,";") > 0 THEN _
  2860.          CALL QTPUT1 ("Cannot use ';'") : _
  2861.          GOTO 62670
  2862.       IF DISALLOW.SPACES THEN _
  2863.          IF B$ = SPACE$(LEN(B$)) THEN _
  2864.             CALL QTPUT1 ("Not all blanks") : _
  2865.             GOTO 62670
  2866.       CALL ALLCAPS (B$)
  2867.       Z$ = B$
  2868.       END SUB
  2869. 63000 ' $SUBTITLE: 'TIMEDOUT - exits based on time of day'
  2870. ' $PAGE
  2871. '
  2872. '  NAME    --  TIMEDOUT
  2873. '
  2874. '  INPUTS  --  PARAMETER                   MEANING
  2875. '              RCTTY.BAT$
  2876. '              NODE.RECORD.INDEX
  2877. '              MESSAGE.RECORD$
  2878. '              MODEM.INIT.BAUD$
  2879. '              MODEM.GO.OFFHOOK.COMMADN$
  2880. '
  2881. '  OUTPUTS --  NONE
  2882. '
  2883. '  PURPOSE --  When RBBS-PC is to exit to DOS at a specific time of
  2884. '              day, this routine writes out to the file specified
  2885. '              in "RCTTY.BAT$" the one-line entry:
  2886. '                          RBBSxTM.BAT
  2887. '               WHERE "x" is the node id.
  2888. '
  2889.       SUB TIMEDOUT STATIC
  2890.       FIELD #1,128 AS MESSAGE.RECORD$
  2891.       SUBROUTINE.PARAMETER = 3
  2892.       CALL FILELOCK
  2893.       GET 1,NODE.RECORD.INDEX
  2894.       X$ = DATE$
  2895.       CALL CSTRDATE (X$,Y$)
  2896.       MID$(MESSAGE.RECORD$,77,2) = Y$
  2897.       'MID$(MESSAGE.RECORD$,86,5) = LEFT$(TIME$,5)
  2898.       PUT 1,NODE.RECORD.INDEX
  2899.       SUBROUTINE.PARAMETER = 2
  2900.       CALL FILELOCK
  2901.       CLOSE 2
  2902.       CALL BRKFNAME(CALLERS.FILE$,X$,Y$,Z$,TRUE)
  2903.       FILE.NAME$ = X$ + "RBBS" + NODE.FILE.ID$ + "TM.DEF"
  2904.       OPEN "O",2,FILE.NAME$
  2905.       PRINT #2,MID$(FILE.NAME$,3,7)
  2906.       CLOSE 2
  2907.       IF LOCAL.USER.MODE THEN _
  2908.          EXIT SUB
  2909.       IF SUBROUTINE.PARAMETER <> 7 THEN _
  2910.          SUBROUTINE.PARAMETER = 4 : _
  2911.          CALL FILELOCK : _
  2912.          CALL OPENCOM(MODEM.INIT.BAUD$,",N,8,1")
  2913.       CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$)
  2914.       IF MULTI.LINK.PRESENT <> 0 THEN _
  2915.          CALL DELAYIT (3)
  2916.       END SUB
  2917. 64003 ' $SUBTITLE: 'ASKUSERS - subroutine to get registration information'
  2918. ' $PAGE
  2919. '
  2920. '  NAME    --  ASKUSERS  (WRITTEN BY JON MARTIN)
  2921. '
  2922. '  INPUTS  --  PARAMETER                   MEANING
  2923. '              FILE.NAME$           NAME OF THE FILE CONTAINING THE
  2924. '                                   SCRIPT TO BE USED WHEN ASKING
  2925. '                                   THE USER QUESTIONS.
  2926. '              ACTIVE.USER.NAME$    NAME OF THE CURRENT USER
  2927. '              USER.SECURITY.LEVEL  USER'S SECURITY
  2928. '              UPPER.CASE           SET IF USER NEEDS UPPERCASE
  2929. '
  2930. '  OUTPUTS --  WRITE THE USER'S RESPONSES TO THE QUESTIONS TO THE
  2931. '              FILE NAME SPECIFIED AS THE FIRST PARAMETER IN THE
  2932. '              FIRST RECORD OF THE FILE CONTAINING THE SCRIPT TO
  2933. '              BE USED.
  2934. '              USER.SECURITY.LEVEL  CAN BE RAISED OR LOWERED
  2935. '
  2936. '  PURPOSE --  Provides a sophisticated, script driven mechanism by
  2937. '              which a sysop can solicit information from new users
  2938. '              (via a script that requests registration information
  2939. '              and which can raise or lower his default security
  2940. '              level based on the responses) or ask a questions of
  2941. '              when the user logs off.  The former occurs if the
  2942. '              file "RBBS-REG.DEF" containing the registration
  2943. '              script exists on the same drive as the "WELCOME".
  2944. '              The later exists if the file "EPILOG.DEF" exists on
  2945. '              the same drive as the "WELCOME".
  2946. '
  2947.       SUB ASKUSERS STATIC
  2948.       QUESTIONNAIRE.ABORTED = FALSE
  2949.       QUESTIONNAIRE.CHAIN.STARTED = FALSE                            ' KG060301
  2950.       REDIM A$(256)
  2951.       REDIM WORK.ARA$(MAX.WORK.VAR),GSR.ARA$(MAX.WORK.VAR)
  2952.       PREV.APPEND$ = ""                                              ' MZ060301
  2953. '
  2954. '
  2955. ' *  LOAD SCRIPT CONTAINING THE QUESTIONS INTO THE A$ DIMENSION  *
  2956. '
  2957. '
  2958. 64005 CHAT.AVAILABLE = FALSE
  2959.       QUESTIONNAIRE.CHAIN = FALSE
  2960.       LAST.QUES = 0
  2961.       CALL GRAPHIC (USER.GRAPHIC.DEFAULT$,FILE.NAME$)                ' KG060301
  2962.       IF NOT OK THEN _                                               ' KG060301
  2963.          EXIT SUB                                                    ' KG060301
  2964.       CALL READPARMS (A$(),2,1)
  2965.       IF EC > 0 THEN _
  2966.          EXIT SUB
  2967.       PREV.APPEND$ = APPEND.FILE.NAME$                               ' MZ060301
  2968.       APPEND.FILE.NAME$ = A$(1)
  2969.       MAXIMUM.SECURITY.LEVEL = VAL(A$(2))
  2970.       X = INSTR(A$(2)," ")
  2971.       IF X > 0 THEN _
  2972.          IF USER.SECURITY.LEVEL < VAL(MID$(A$(2),X)) THEN _
  2973.             CALL QTPUT1 ("Higher security needed for this questionnaire") : _
  2974.             EXIT SUB
  2975. '
  2976. '
  2977. ' *  THE FIRST RECORD OF THE SCRIPT FILE CONTAINS THREE PARAMETERS:
  2978. ' *   1.  THE NAME OF THE FILE TO APPEND THE ANSWERS TO.
  2979. ' *   2.  THE MAXIMUM SECURITY LEVEL THE + COMMAND CAN RAISE A USER SECURITY
  2980. ' *   3.  THE MINIMUM SECURITY TO USE THIS QUESTIONNAIRE
  2981. ' * e.g. 'C:XXX.DAT,6 5' writes answers to C:XXX.DAT, can raise to 6,
  2982. ' *      and requires security 5 or more to access
  2983.       SCRIPT.INDEX = 1
  2984.       A$(SCRIPT.INDEX) = ACTIVE.USER.NAME$ + _
  2985.                          " " + _
  2986.                          DATE$ + _
  2987.                          " " + _
  2988.                          TIME$
  2989. 64010 IF EOF(2) OR SCRIPT.INDEX > 255 THEN _
  2990.          GOTO 64100
  2991.       SCRIPT.INDEX = SCRIPT.INDEX + 1
  2992.       LINE INPUT #2,A$(SCRIPT.INDEX)
  2993.       IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _
  2994.          CALL ALLCAPS (A$(SCRIPT.INDEX)) : _
  2995.          CALL TRIM (A$(SCRIPT.INDEX))
  2996.       IF UPPER.CASE THEN _
  2997.          CALL ALLCAPS (A$(SCRIPT.INDEX))
  2998.       IF LEFT$(A$(SCRIPT.INDEX),1) = "?" THEN _
  2999.          SCRIPT.INDEX = SCRIPT.INDEX + 1 : _
  3000.          A$(SCRIPT.INDEX) = "!"
  3001.       GOTO 64010
  3002. '
  3003. '
  3004. ' *  PROCESS QUESTIONS IN THE SCRIPT AS FOLLOWS:
  3005. ' *
  3006. ' * FIRST COLUMN     MEANING
  3007. ' *      :        THIS LINE IS A LABEL THAT MAY BE BRANCHED TO
  3008. ' *      !        THIS MEANS THIS IS AN ANSWER
  3009. ' *      >        THIS IS A "GOTO" COMMAND TO ONE OF THE LABELS
  3010. ' *      *        THIS MEANS THE LINE IS A MESSAGE TO BE WRITTEN TO THE USER
  3011. ' *      ?        THIS MEANS THIS IS A QUESTION FOR THE USER
  3012. ' *      =        THIS MEANS THAT THIS LINE CONTAINS DECISION CRITERIA
  3013. ' *      -        THIS MEANS TO LOWER THE USER'S SECURITY LEVEL
  3014. ' *      +        THIS MEANS TO RAISE THE USER'S SECURITY LEVEL
  3015. ' *      @        THIS MEANS TO ABORT THE QUESTIONNAIRE DO NOT WRITE OUT
  3016. ' *      &        THIS MEANS TO CHAIN TO ANOTHER QUESTIONNAIRE
  3017. ' *      M        Execute specified macro
  3018. ' *      T        Turbo Key
  3019. ' *      <        Assign value to work variable
  3020. '
  3021. 64100 SCRIPT.MAX = SCRIPT.INDEX
  3022.       SCRIPT.INDEX = 1
  3023. 64110 CALL CARRIER
  3024.       IF SUBROUTINE.PARAMETER = -1 THEN _
  3025.          GOTO 64115
  3026.       SCRIPT.INDEX = SCRIPT.INDEX + 1
  3027.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  3028.          GOTO 64400
  3029.       A$ = MID$(A$(SCRIPT.INDEX),2)
  3030.       X = FALSE
  3031.       IF LEFT$(A$,3) = "/FL" THEN _
  3032.          A$ = RIGHT$(A$,LEN(A$)-3) : _
  3033.          X = TRUE
  3034.       CALL METAGSR (A$,X)
  3035.       CALL SMARTTXT (A$,FALSE,X)
  3036.       X$ = A$
  3037.       IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _         ' LABEL
  3038.          GOTO 64110
  3039.       IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _         ' ANSWER
  3040.          GOTO 64110
  3041.       IF LEFT$(A$(SCRIPT.INDEX),1) = "@" THEN _         ' ABORT
  3042.          QUESTIONNAIRE.ABORTED = TRUE : _
  3043.          GOTO 64510
  3044.       IF LEFT$(A$(SCRIPT.INDEX),1) = "M" THEN _         ' MACRO
  3045.          GOTO 64120
  3046.       IF LEFT$(A$(SCRIPT.INDEX),1) = "T" THEN _
  3047.          TURBO.KEY = -TURBO.KEY.USER : _
  3048.          GOTO 64110
  3049.       IF LEFT$(A$(SCRIPT.INDEX),1) = ">" THEN _         ' GOTO
  3050.          BRANCH.LABEL$ = A$ : _
  3051.          GOSUB 64200 : _
  3052.          IF SUBROUTINE.PARAMETER = -1 THEN _
  3053.             GOTO 64510 _
  3054.          ELSE GOTO 64110
  3055.       IF LEFT$(A$(SCRIPT.INDEX),1) = "<" THEN _
  3056.          GOTO 64190
  3057.       IF LEFT$(A$(SCRIPT.INDEX),1) = "*" THEN _         ' MESSAGE
  3058.          SUBROUTINE.PARAMETER = 5 : _
  3059.          CALL TPUT : _
  3060.          IF SUBROUTINE.PARAMETER = -1 THEN _
  3061.             GOTO 64510 _
  3062.          ELSE GOTO 64110
  3063. 64113 IF LEFT$(A$(SCRIPT.INDEX),1) <> "?" THEN _    ' QUESTION
  3064.          GOTO 64114
  3065.       LAST.QUES = SCRIPT.INDEX
  3066.       GOSUB 64180
  3067.       SUBROUTINE.PARAMETER = 1
  3068.       CALL TGET
  3069.       IF SUBROUTINE.PARAMETER = -1 THEN _
  3070.          GOTO 64510 _
  3071.       ELSE IF Q = 0 THEN _
  3072.               A$ = X$ : _
  3073.               GOTO 64113 _
  3074.            ELSE A$(SCRIPT.INDEX + 1) = "!" + _
  3075.                                        B$ : _
  3076.                 GSR.ARA$(TESTED.INTEGER.VALUE) = B$
  3077.       GOTO 64110
  3078. 64114 IF LEFT$(A$(SCRIPT.INDEX),2) = "=#" THEN _       ' NUMERIC
  3079.          GOSUB 64350 : _
  3080.          GOTO 64110
  3081.       IF LEFT$(A$(SCRIPT.INDEX),1) = "=" THEN _         ' DECISION
  3082.          GOSUB 64300 : _
  3083.          IF SUBROUTINE.PARAMETER = -1 THEN _
  3084.             GOTO 64510 _
  3085.          ELSE GOTO 64110
  3086.       IF LEFT$(A$(SCRIPT.INDEX),1) = "-" THEN _         ' LOWER
  3087.          ADJUSTED.SECURITY = -1 : _
  3088.          USER.SECURITY.LEVEL = USER.SECURITY.LEVEL - _
  3089.                                VAL(MID$(A$(SCRIPT.INDEX),2,5)) : _
  3090.          USER.SECURITY.SAVE = USER.SECURITY.LEVEL : _
  3091.          GOTO 64110
  3092.       IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _         ' RAISE
  3093.          IF USER.SECURITY.LEVEL + VAL(MID$(A$(SCRIPT.INDEX),2,5)) _
  3094.             <= MAXIMUM.SECURITY.LEVEL THEN _
  3095.                ADJUSTED.SECURITY = -1 : _
  3096.                USER.SECURITY.SAVE = USER.SECURITY.LEVEL : _
  3097.                USER.SECURITY.LEVEL = USER.SECURITY.LEVEL + _
  3098.                                VAL(MID$(A$(SCRIPT.INDEX),2,5))
  3099.       IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _
  3100.          GOTO 64110
  3101.       IF LEFT$(A$(SCRIPT.INDEX),1) = "&" THEN _
  3102.          QUESTIONNAIRE.CHAIN = TRUE : _
  3103.          FILE.NAME.HOLD$ = A$ : _
  3104.          GOTO 64110
  3105.       A$ = "Invalid line.  Column 1 is <" + LEFT$(A$(SCRIPT.INDEX),1)+">.  Must be: * ? = + - > @ & M T <"
  3106.       SUBROUTINE.PARAMETER = 5
  3107.       CALL TPUT
  3108. 64115 GOTO 64510
  3109. 64120 Z$ = MID$(A$(SCRIPT.INDEX),2)   ' Execute macro
  3110.       CALL TRIM (Z$)                                                 ' KG062801
  3111.       CALL ACHKMAC (Z$,FOUND)                                        ' KG062801
  3112.       IF FOUND THEN _                                                ' KG062801
  3113.           CALL FDMACEXE                                              ' KG062801
  3114.       GOTO 64110
  3115. 64180 CALL CHECKINT (A$)
  3116.       IF (EC > 0) OR (TESTED.INTEGER.VALUE < 1) OR _
  3117.           (TESTED.INTEGER.VALUE > MAX.WORK.VAR) OR _
  3118.           (INSTR("123456789",LEFT$(A$,1)) = 0) THEN _
  3119.              TESTED.INTEGER.VALUE = 0 _
  3120.       ELSE A$ = RIGHT$(A$,LEN(A$)-1+(TESTED.INTEGER.VALUE > 9))
  3121.       RETURN
  3122. 64190 GOSUB 64180
  3123.       IF TESTED.INTEGER.VALUE > 0 THEN _
  3124.          GSR.ARA$(TESTED.INTEGER.VALUE) = MID$(A$,2)
  3125.       GOTO 64110
  3126. '
  3127. '
  3128. ' *  SEARCH FOR GOTO LABEL
  3129. '
  3130. '
  3131. 64200 SCRIPT.INDEX = 1
  3132.       CALL METAGSR (BRANCH.LABEL$,FALSE)
  3133.       CALL SMARTTXT (BRANCH.LABEL$,FALSE,FALSE)
  3134.       CALL ALLCAPS (BRANCH.LABEL$)
  3135.       CALL TRIM (BRANCH.LABEL$)
  3136. 64210 SCRIPT.INDEX = SCRIPT.INDEX + 1
  3137.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  3138.          A$ = BRANCH.LABEL$ + _
  3139.               " not found!" : _
  3140.          SUBROUTINE.PARAMETER = 5 : _
  3141.          CALL TPUT : _
  3142.          IF SUBROUTINE.PARAMETER = -1 THEN _
  3143.             RETURN _
  3144.          ELSE IF LAST.QUES > 0 THEN _
  3145.                  SCRIPT.INDEX = LAST.QUES - 1 : _
  3146.                  RETURN _
  3147.               ELSE GOTO 64115
  3148.       IF LEFT$(A$(SCRIPT.INDEX),1) <> ":" THEN _
  3149.          GOTO 64210
  3150.       IF MID$(A$(SCRIPT.INDEX),2) <> BRANCH.LABEL$ THEN _
  3151.          GOTO 64210
  3152.       RETURN
  3153. '
  3154. '
  3155. ' *  DETERMINE BRANCH LOGIC
  3156. '
  3157. '
  3158. 64300 CURRENT.EQUALS = 1
  3159.       Z$ = RIGHT$(A$(LAST.QUES + 1),1)
  3160.       CALL ALLCAPS (Z$)
  3161. 64310 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
  3162.       IF NEXT.EQUALS = 0 THEN _
  3163.          BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
  3164.          GOTO 64320
  3165.       IF Z$ <> _
  3166.          MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 1,1) THEN  _
  3167.          CURRENT.EQUALS = NEXT.EQUALS : _
  3168.          GOTO 64310
  3169.       BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2))
  3170. 64320 GOSUB 64200
  3171.       RETURN
  3172. '
  3173. '
  3174. ' *  DETERMINE NUMERIC BRANCH LOGIC
  3175. '
  3176. '
  3177. 64350 CURRENT.EQUALS = 1
  3178. 64360 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
  3179.       IF NEXT.EQUALS = 0 THEN _
  3180.          BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
  3181.          GOTO 64380
  3182.       NUMERIC = TRUE
  3183.       LOOP.INDEX = 2
  3184.       WHILE LOOP.INDEX < LEN(A$(SCRIPT.INDEX - 1)) +1
  3185.          IF INSTR("()1234567890- ",MID$(A$(SCRIPT.INDEX - 1),LOOP.INDEX,1)) THEN _
  3186.             GOTO 64370
  3187.          NUMERIC = FALSE
  3188. 64370    LOOP.INDEX = LOOP.INDEX + 1
  3189.       WEND
  3190.       IF NOT NUMERIC THEN _
  3191.          CURRENT.EQUALS = NEXT.EQUALS : _
  3192.          GOTO 64360
  3193.       BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2))
  3194. 64380 GOSUB 64200
  3195.       RETURN
  3196. '
  3197. '
  3198. ' *  WRITE RESPONSES TO DESIGNATED FILE
  3199. '
  3200. '
  3201. 64400 SCRIPT.INDEX = 0
  3202.       EN$ = APPEND.FILE.NAME$
  3203.       CALL LOCKAPPND
  3204.       IF EC <> 0 THEN _
  3205.          A$ = "Fatal Error in script!" : _
  3206.          SUBROUTINE.PARAMETER = 5 : _
  3207.          CALL TPUT : _
  3208.          GOTO 64500
  3209. 64410 SCRIPT.INDEX = SCRIPT.INDEX + 1
  3210.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  3211.          GOTO 64500
  3212.       IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _
  3213.          QUESTION.SAVE$ = MID$(A$(SCRIPT.INDEX),2) : _
  3214.          GOTO 64410
  3215.       IF LEFT$(A$(SCRIPT.INDEX),1) = "!" AND _
  3216.          LEN(A$(SCRIPT.INDEX)) < 2 THEN _
  3217.          GOTO 64410
  3218.       IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _
  3219.          CALL PRNTWRKA (QUESTION.SAVE$) : _
  3220.          CALL PRNTWRKA (MID$(A$(SCRIPT.INDEX),2))
  3221.       IF SCRIPT.INDEX = 1 AND _
  3222.          APPEND.FILE.NAME$ <> PREV.APPEND$ THEN _                    ' MZ060301
  3223.          CALL PRNTWRKA (A$(SCRIPT.INDEX))
  3224.       IF EC <> 0 THEN _
  3225.          A$ = "Unrecoverable failure in script!" : _
  3226.          SUBROUTINE.PARAMETER = 5 : _
  3227.          CALL TPUT : _
  3228.          GOTO 64500
  3229.       GOTO 64410
  3230. 64500 CALL UNLKAPPND
  3231.       CALL CARRIER
  3232.       IF QUESTIONNAIRE.CHAIN THEN _
  3233.          QUESTIONNAIRE.CHAIN.STARTED = TRUE : _
  3234.          FILE.NAME$ = FILE.NAME.HOLD$ : _
  3235.          GOTO 64005
  3236. 64510 CHAT.AVAILABLE = (INSTR("MUF",ACTIVE.MENU$) > 0)
  3237.       OK = TRUE
  3238.       END SUB
  3239. 64600 ' $SUBTITLE: 'VIEWARC - subroutine to display .ARC contents'
  3240. ' $PAGE
  3241. '
  3242. '  NAME    --  VIEWARC  (Written by Jon Martin)
  3243. '
  3244. '  INPUTS  --  PARAMETER                   MEANING
  3245. '              FILE.NAME$           NAME OF THE ARC FILE TO BE
  3246. '                                      VIEWED.
  3247. '
  3248. '  OUTPUTS --  NONE
  3249. '
  3250. '  PURPOSE --  Provides a mechanism to provide users with the
  3251. '              contents of a libraried file prior to downloading.
  3252. '
  3253.       SUB VIEWARC STATIC
  3254.       CLOSE 2
  3255.       IF TURBO.RBBS THEN _
  3256.          RETCODE% = 0 : _
  3257.          CALL ARCV (ARC.WORK$,FILE.NAME$,RETCODE%) : _
  3258.          CALL BUFFILE (ARC.WORK$,X) : _
  3259.          EXIT SUB
  3260.       IF SHARE.IT THEN _
  3261.          OPEN FILE.NAME$ FOR RANDOM SHARED AS #2 LEN=1 _
  3262.       ELSE OPEN "R",2,FILE.NAME$,1
  3263.       FIELD 2,1 AS CHAR$
  3264.       BYTE.POINTER! = 1
  3265.       ARC.END! = LOF(2)
  3266. 64605 IF BYTE.POINTER! > ARC.END! THEN _
  3267.          GOTO 64620
  3268.       GET 2,BYTE.POINTER!
  3269.       IF CHAR$ <> CHR$(26) THEN _
  3270.          GOTO 64620
  3271.       BYTE.POINTER! = BYTE.POINTER! + 1
  3272.       GET 2,BYTE.POINTER!
  3273.       IF CHAR$ = CHR$(0) THEN _
  3274.          GOTO 64620
  3275.       ARCED.NAME$ = ""
  3276.       FOR X = 1 TO 12
  3277.          GET 2,BYTE.POINTER! + X
  3278.          IF CHAR$ < CHR$(40) THEN _
  3279.             GOTO 64610
  3280.          ARCED.NAME$ = ARCED.NAME$ + _
  3281.                        CHAR$
  3282.       NEXT
  3283. 64610 A$ = ARCED.NAME$
  3284.       BYTE.POINTER! = BYTE.POINTER! + 14
  3285.       GOSUB 64630
  3286.       TOTAL.BYTES# = WORK.BYTES#
  3287.       BYTE.POINTER! = BYTE.POINTER! + 10
  3288.       GOSUB 64630
  3289.       FINAL.BYTES# = WORK.BYTES#
  3290.       A$ = A$ + _
  3291.            SPACE$(20 - LEN(ARCED.NAME$) - LEN(STR$(FINAL.BYTES#))) + _
  3292.            STR$(FINAL.BYTES#) + _
  3293.            " bytes."
  3294.       CALL QTPUT1 (A$)
  3295.       BYTE.POINTER! = BYTE.POINTER! + TOTAL.BYTES# + 4
  3296.       GOTO 64605
  3297. 64620 CLOSE 2
  3298.       SUBROUTINE.PARAMETER = 0
  3299.       CALL CARRIER
  3300.       A$ = ""
  3301.       EXIT SUB
  3302. 64630 FACTOR# = 1#
  3303.       WORK.BYTES# = 0
  3304.       FOR X = 0 TO 3
  3305.          GET 2,BYTE.POINTER! + X
  3306.          WORK.BYTES# = WORK.BYTES# + FACTOR# * ASC(CHAR$)
  3307.          FACTOR# = FACTOR# * 256#
  3308.       NEXT
  3309.       RETURN
  3310.       END SUB
  3311.